mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 05:27:35 +02:00
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.
This commit is contained in:
Alex Shinn
parent
adbf0d9370
commit
cc6f727add
9 changed files with 83 additions and 77 deletions
44
eval.c
44
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;
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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) {
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 <time.h>
|
||||
#include <chibi/eval.h>
|
||||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
22
main.c
22
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);
|
||||
|
|
|
|||
62
sexp.c
62
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<len; i++, p++) {
|
||||
c = *p;
|
||||
if ((unsigned char)c > 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);
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue