Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 13:37:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

sexp_intern, sexp_read_from_string and sexp_eval_string now all take length parameters.

Browse source 
this is more flexible and will help if strings are changed to be non-null-terminated.
This commit is contained in:
Alex Shinn 2010-03-23 20:52:47 +09:00
parent adbf0d9370
commit cc6f727add
9 changed files with 83 additions and 77 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

44
eval.c
View file

@ -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); static sexp sexp_find_module_file_op (sexp ctx, sexp file);
#endif #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 exn;
sexp_gc_var3(sym, irritants, msg); sexp_gc_var3(sym, irritants, msg);
sexp_gc_preserve3(ctx, 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); msg = sexp_c_string(ctx, message, -1);
exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile"), msg, irritants, exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1),
SEXP_FALSE, (sexp_pairp(obj) ? msg, irritants, SEXP_FALSE,
sexp_pair_source(obj) : SEXP_FALSE)); (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE));
sexp_gc_release3(ctx); sexp_gc_release3(ctx);
return exn; return exn;
} }
@ -325,7 +325,7 @@ void sexp_init_eval_context_globals (sexp ctx) {
sexp_gc_var2(tmp, vec); sexp_gc_var2(tmp, vec);
ctx = sexp_make_child_context(ctx, NULL); ctx = sexp_make_child_context(ctx, NULL);
sexp_gc_preserve2(ctx, tmp, vec); 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_global(ctx, SEXP_G_ERR_HANDLER)
= sexp_env_cell_create(ctx, sexp_context_env(ctx), tmp, SEXP_FALSE, NULL); = sexp_env_cell_create(ctx, sexp_context_env(ctx), tmp, SEXP_FALSE, NULL);
emit(ctx, SEXP_OP_RESUMECC); 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_global(ctx, SEXP_G_FINAL_RESUMER)
= sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec);
sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) 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_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL;
sexp_add_path(ctx, sexp_default_module_dir); sexp_add_path(ctx, sexp_default_module_dir);
sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); 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)) if (sexp_exceptionp(op))
res = op; res = op;
else 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); sexp_gc_release1(ctx);
return res; return res;
} }
@ -2394,7 +2394,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar
sexp res; sexp res;
sexp_gc_var1(tmp); sexp_gc_var1(tmp);
sexp_gc_preserve1(ctx, tmp); sexp_gc_preserve1(ctx, tmp);
tmp = sexp_intern(ctx, param); tmp = sexp_intern(ctx, param, -1);
tmp = sexp_env_cell(env, tmp); tmp = sexp_env_cell(env, tmp);
res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp);
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
@ -2477,7 +2477,7 @@ sexp sexp_make_null_env (sexp ctx, sexp version) {
sexp_uint_t i; sexp_uint_t i;
sexp e = sexp_make_env(ctx); sexp e = sexp_make_env(ctx);
for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) 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])); sexp_copy_core(ctx, &core_forms[i]));
return e; 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++) { for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) {
op = sexp_copy_opcode(ctx, &opcodes[i]); op = sexp_copy_opcode(ctx, &opcodes[i]);
if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { 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_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); sexp_gc_release3(ctx);
return e; 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_gc_preserve3(ctx, op, tmp, sym);
sexp_load_standard_parameters(ctx, e); sexp_load_standard_parameters(ctx, e);
#if SEXP_USE_DL #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)); tmp=sexp_c_string(ctx, sexp_so_extension, -1));
#endif #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 #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 #endif
#if SEXP_USE_MODULES #if SEXP_USE_MODULES
sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules")); sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules", -1));
#endif #endif
#if SEXP_USE_BOEHM #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 #endif
sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1));
sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp);
sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL;
#if SEXP_USE_SIMPLIFY #if SEXP_USE_SIMPLIFY
op = sexp_make_foreign(ctx, "simplify", 1, 0, 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 */ /* load and bind config env */
#if SEXP_USE_MODULES #if SEXP_USE_MODULES
if (! sexp_exceptionp(tmp)) { 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))) { if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) {
tmp = sexp_make_env(ctx); tmp = sexp_make_env(ctx);
if (! sexp_exceptionp(tmp)) { if (! sexp_exceptionp(tmp)) {
@ -2768,11 +2768,11 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) {
return res; 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 res;
sexp_gc_var1(obj); sexp_gc_var1(obj);
sexp_gc_preserve1(ctx, 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); res = sexp_eval(ctx, obj, env);
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
return res; return res;

4
include/chibi/sexp.h
View file

@ -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_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_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_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_string_to_symbol(sexp ctx, sexp str);
SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls); 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_number(sexp ctx, sexp in, int base);
SEXP_API sexp sexp_read_raw(sexp ctx, sexp in); SEXP_API sexp sexp_read_raw(sexp ctx, sexp in);
SEXP_API sexp sexp_read(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_write_to_string(sexp ctx, sexp obj);
SEXP_API sexp sexp_finalize_port (sexp ctx, sexp port); SEXP_API sexp sexp_finalize_port (sexp ctx, sexp port);
SEXP_API sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); SEXP_API sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name);

8
lib/chibi/ast.c
View file

@ -10,7 +10,7 @@ static void sexp_define_type_predicate (sexp ctx, sexp env,
sexp_gc_preserve2(ctx, name, op); sexp_gc_preserve2(ctx, name, op);
name = sexp_c_string(ctx, cname, -1); name = sexp_c_string(ctx, cname, -1);
op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); 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); 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); type = sexp_make_fixnum(ctype);
index = sexp_make_fixnum(cindex); index = sexp_make_fixnum(cindex);
op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); 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); 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); sexp_gc_release2(ctx);
} }
@ -43,7 +43,7 @@ static sexp sexp_get_opcode_name (sexp ctx, sexp op) {
else if (! sexp_opcode_name(op)) else if (! sexp_opcode_name(op))
return SEXP_FALSE; return SEXP_FALSE;
else 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) { sexp sexp_init_library (sexp ctx, sexp env) {

2
lib/chibi/heap-stats.c
View file

@ -103,7 +103,7 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) {
res = SEXP_NULL; res = SEXP_NULL;
for (i=hi_type; i>0; i--) for (i=hi_type; i>0; i--)
if (stats[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])); tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i]));
res = sexp_cons(ctx, tmp, res); res = sexp_cons(ctx, tmp, res);
} }

6
lib/srfi/27/rand.c
View file

@ -1,5 +1,5 @@
/* rand.c -- rand_r/random_r interface */ /* rand.c -- rand_r/random_r interface */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
#include <time.h> #include <time.h>
@ -180,7 +180,7 @@ sexp sexp_init_library (sexp ctx, sexp env) {
name = sexp_c_string(ctx, "random-source?", -1); name = sexp_c_string(ctx, "random-source?", -1);
op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id)); 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_env_define(ctx, env, name, op);
sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source); 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); sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 2, sexp_random_source_pseudo_randomize);
default_random_source = op = sexp_make_random_source(ctx); 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_env_define(ctx, env, name, default_random_source);
sexp_random_source_randomize(ctx, default_random_source); sexp_random_source_randomize(ctx, default_random_source);

2
lib/srfi/69/hash.c
View file

@ -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)); args = sexp_list2(ctx, obj, sexp_make_fixnum(len));
res = sexp_apply(ctx, hash_fn, args); res = sexp_apply(ctx, hash_fn, args);
if (sexp_exceptionp(res)) { 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); sexp_print_exception(ctx, res, args);
res = sexp_make_fixnum(0); res = sexp_make_fixnum(0);
} }

22
main.c
View file

@ -27,9 +27,9 @@ static void repl (sexp ctx) {
sexp_env_define(ctx, sexp_context_env(ctx), sexp_env_define(ctx, sexp_context_env(ctx),
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env);
sexp_context_tracep(ctx) = 1; sexp_context_tracep(ctx) = 1;
in = sexp_eval_string(ctx, "(current-input-port)", env); in = sexp_eval_string(ctx, "(current-input-port)", -1, env);
out = sexp_eval_string(ctx, "(current-output-port)", env); out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
err = sexp_eval_string(ctx, "(current-error-port)", env); err = sexp_eval_string(ctx, "(current-error-port)", -1, env);
sexp_port_sourcep(in) = 1; sexp_port_sourcep(in) = 1;
while (1) { while (1) {
sexp_write_string(ctx, "> ", out); sexp_write_string(ctx, "> ", out);
@ -106,11 +106,11 @@ void run_main (int argc, char **argv) {
print = (argv[i][1] == 'p'); print = (argv[i][1] == 'p');
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('e', arg); 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)); res = check_exception(ctx, sexp_eval(ctx, res, env));
if (print) { if (print) {
if (! sexp_oportp(out)) 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(ctx, res, out);
sexp_write_char(ctx, '\n', out); sexp_write_char(ctx, '\n', out);
} }
@ -134,7 +134,7 @@ void run_main (int argc, char **argv) {
impmod[len] = '\0'; impmod[len] = '\0';
for (p=impmod; *p; p++) for (p=impmod; *p; p++)
if (*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); free(impmod);
break; break;
case 'q': case 'q':
@ -171,9 +171,9 @@ void run_main (int argc, char **argv) {
case 'V': case 'V':
load_init(); load_init();
if (! sexp_oportp(out)) 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); 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_write(ctx, tmp, out);
sexp_newline(ctx, out); sexp_newline(ctx, out);
return; 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); args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args);
else else
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); 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_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args);
sexp_eval_string(ctx, sexp_argv_proc, env); sexp_eval_string(ctx, sexp_argv_proc, -1, env);
if (i < argc) { /* script usage */ if (i < argc) { /* script usage */
check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); 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); tmp = sexp_env_ref(env, tmp, SEXP_FALSE);
if (sexp_procedurep(tmp)) { if (sexp_procedurep(tmp)) {
args = sexp_list1(ctx, args); args = sexp_list1(ctx, args);

62
sexp.c
View file

@ -224,14 +224,14 @@ void sexp_init_context_globals (sexp ctx) {
#endif #endif
sexp_global(ctx, SEXP_G_OOM_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of memory", SEXP_NULL); 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_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_QUOTE_SYMBOL) = sexp_intern(ctx, "quote", -1);
sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote"); sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote", -1);
sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote"); 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"); 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*"); 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*"); 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*"); 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*"); 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_global(ctx, SEXP_G_EMPTY_VECTOR) = sexp_alloc_type(ctx, vector, SEXP_VECTOR);
sexp_vector_length(sexp_global(ctx, SEXP_G_EMPTY_VECTOR)) = 0; sexp_vector_length(sexp_global(ctx, SEXP_G_EMPTY_VECTOR)) = 0;
#if ! SEXP_USE_GLOBAL_TYPES #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 res;
sexp_gc_var3(sym, str, irr); sexp_gc_var3(sym, str, irr);
sexp_gc_preserve3(ctx, 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), str = sexp_c_string(ctx, ms, -1),
((sexp_pairp(ir) || sexp_nullp(ir)) ((sexp_pairp(ir) || sexp_nullp(ir))
? ir : (irr = sexp_list1(ctx, 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 res;
sexp_gc_var3(sym, str, irr); sexp_gc_var3(sym, str, irr);
sexp_gc_preserve3(ctx, 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), str = sexp_c_string(ctx, message, -1),
irr = sexp_list1(ctx, obj), irr = sexp_list1(ctx, obj),
SEXP_FALSE, SEXP_FALSE); 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); msg = sexp_c_string(ctx, "bad index range", -1);
res = sexp_list2(ctx, start, end); res = sexp_list2(ctx, start, end);
res = sexp_cons(ctx, obj, res); 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_FALSE, SEXP_FALSE);
sexp_gc_release2(ctx); sexp_gc_release2(ctx);
return res; 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))); name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port)));
str = sexp_c_string(ctx, msg, -1); str = sexp_c_string(ctx, msg, -1);
irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir)); 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); str, irr, SEXP_FALSE, name);
sexp_gc_release4(ctx); sexp_gc_release4(ctx);
return res; return res;
@ -694,27 +694,31 @@ sexp sexp_string_concatenate (sexp ctx, sexp str_ls, sexp sep) {
#if SEXP_USE_HASH_SYMS #if SEXP_USE_HASH_SYMS
static sexp_uint_t sexp_string_hash(const char *str, sexp_uint_t acc) { static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len,
while (*str) {acc *= FNV_PRIME; acc ^= *str++;} sexp_uint_t acc) {
for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;}
return acc; return acc;
} }
#endif #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 #if SEXP_USE_HUFF_SYMS
struct sexp_huff_entry he; struct sexp_huff_entry he;
sexp_uint_t space=3, newbits; sexp_uint_t space=3, newbits;
char c; char c;
#endif #endif
sexp_uint_t len, res=FNV_OFFSET_BASIS, bucket; sexp_uint_t res=FNV_OFFSET_BASIS, bucket, i=0;
const char *p=str; const char *p=str;
sexp ls; sexp ls, tmp;
sexp_gc_var1(sym); sexp_gc_var1(sym);
if (len < 0) len = strlen(str);
#if SEXP_USE_HUFF_SYMS #if SEXP_USE_HUFF_SYMS
res = 0; res = 0;
for ( ; (c=*p); p++) { for ( ; i<len; i++, p++) {
c = *p;
if ((unsigned char)c > 127) if ((unsigned char)c > 127)
goto normal_intern; goto normal_intern;
he = huff_table[(unsigned char)c]; he = huff_table[(unsigned char)c];
@ -729,20 +733,20 @@ sexp sexp_intern(sexp ctx, const char *str) {
normal_intern: normal_intern:
#endif #endif
#if SEXP_USE_HASH_SYMS #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 #else
bucket = 0; bucket = 0;
#endif #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)) 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); return sexp_car(ls);
/* not found, make a new symbol */ /* not found, make a new symbol */
sexp_gc_preserve1(ctx, sym); sexp_gc_preserve1(ctx, sym);
sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL);
if (sexp_exceptionp(sym)) return sym; 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_push(ctx, sexp_context_symbols(ctx)[bucket], sym);
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
return sym; return sym;
@ -751,7 +755,7 @@ sexp sexp_intern(sexp ctx, const char *str) {
sexp sexp_string_to_symbol (sexp ctx, sexp str) { sexp sexp_string_to_symbol (sexp ctx, sexp str) {
if (! sexp_stringp(str)) if (! sexp_stringp(str))
return sexp_type_exception(ctx, "string->symbol: not a string", 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) { 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'; 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); if (size != INIT_STRING_BUFFER_SIZE) free(buf);
return res; return res;
} }
@ -1624,11 +1628,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
sexp_push_char(ctx, c2, in); sexp_push_char(ctx, c2, in);
res = sexp_read_symbol(ctx, in, c1, 1); res = sexp_read_symbol(ctx, in, c1, 1);
#if SEXP_USE_INFINITIES #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); 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); 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); res = sexp_make_flonum(ctx, 0.0/0.0);
#endif #endif
} }
@ -1662,11 +1666,11 @@ sexp sexp_read (sexp ctx, sexp in) {
return res; 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 res;
sexp_gc_var2(s, in); sexp_gc_var2(s, in);
sexp_gc_preserve2(ctx, 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); in = sexp_make_input_string_port(ctx, s);
res = sexp_read(ctx, in); res = sexp_read(ctx, in);
sexp_gc_release2(ctx); sexp_gc_release2(ctx);

6
tools/genstubs.scm
View file

@ -1044,7 +1044,8 @@
(let ((pred (cadr x))) (let ((pred (cadr x)))
(cat " tmp = sexp_make_type_predicate(ctx, name, " (cat " tmp = sexp_make_type_predicate(ctx, name, "
"sexp_make_fixnum(" (type-id-name name) "));\n" "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"))))))) " sexp_env_define(ctx, env, name, tmp);\n")))))))
(define (type-getter-name type name field) (define (type-getter-name type name field)
@ -1183,7 +1184,8 @@
(define (write-const const) (define (write-const const)
(let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const)))
(c-name (if (pair? (cadr const)) (cadadr const) (mangle (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=" " sexp_env_define(ctx, env, name, tmp="
(lambda () (c->scheme-converter (car const) c-name)) ");\n"))) (lambda () (c->scheme-converter (car const) c-name)) ");\n")))