static dfsch_slot_t* make_slots(dfsch_object_t* slot_desc){
dfsch_object_t* i = slot_desc;
size_t slot_count = dfsch_list_length_check(slot_desc);
dfsch_slot_t* slots = GC_MALLOC((slot_count + 1) * sizeof(dfsch_slot_t));
dfsch_slot_t* j = slots;
while (slot_count && DFSCH_PAIR_P(i)){
dfsch_object_t* name;
dfsch_object_t* type;
if (DFSCH_PAIR_P(DFSCH_FAST_CAR(i))){
dfsch_object_t* args = DFSCH_FAST_CAR(i);
DFSCH_OBJECT_ARG(args, name);
} else {
name = DFSCH_FAST_CAR(i);
}
j->type = DFSCH_OBJECT_SLOT_TYPE;
j->name = dfsch_symbol(name);
j->documentation = NULL;
j++;
slot_count--;
i = DFSCH_FAST_CDR(i);
}
j->type = NULL;
j->name = NULL;
j->access = DFSCH_SLOT_ACCESS_RW;
j->documentation = NULL;
return slots;
}
static int command_proc(command_context_t* ctx,
Tcl_Interp* interp,
int argc, char** argv){
dfsch_object_t *head;
dfsch_object_t *cur;
dfsch_object_t *res;
int i;
int ret;
head = cur = dfsch_multicons(argc-1);
for(i = 1; i < argc; ++i){
DFSCH_FAST_CAR(cur) = dfsch_make_string_cstr(argv[i]);
cur = DFSCH_FAST_CDR(cur);
}
DFSCH_SCATCH_BEGIN {
res = dfsch_apply(ctx->proc, head);
Tcl_SetResult(interp, dfsch_object_2_string(res, -1, 0),
TCL_VOLATILE);
ret = TCL_OK;
} DFSCH_SCATCH {
ret = TCL_ERROR;
} DFSCH_SCATCH_END;
return ret;
}
dfsch_object_t* dfsch_compile_expression_list(dfsch_object_t* list,
dfsch_object_t* env){
dfsch_object_t *head;
dfsch_object_t *tail;
dfsch_object_t *i = list;
head = tail = NULL;
while(DFSCH_PAIR_P(i)){
dfsch_object_t* tmp =
dfsch_cons(dfsch_compile_expression(DFSCH_FAST_CAR(i), env), NULL);
if (head){
DFSCH_FAST_CDR_MUT(tail) = tmp;
tail = tmp;
}else{
head = tail = tmp;
}
i = DFSCH_FAST_CDR(i);
}
if (i && !DFSCH_PAIR_P(i)){
dfsch_type_error(i, DFSCH_LIST_TYPE, 1);
}
return dfsch_list_annotate((dfsch_object_t*)head,
DFSCH_SYM_COMPILED_FROM, list);
}
static int all_constants_p(dfsch_object_t* list){
while (DFSCH_PAIR_P(list)){
if (dfsch_constant_expression_value(DFSCH_FAST_CAR(list),
NULL) == DFSCH_INVALID_OBJECT) {
return 0;
}
list = DFSCH_FAST_CDR(list);
}
return 1;
}
static void default_initialize_instance(dfsch_object_t* obj,
class_t* klass,
dfsch_object_t* args){
dfsch_object_t* i = klass->initvalues;
while (DFSCH_PAIR_P(i)){
dfsch_object_t* j = DFSCH_FAST_CAR(i);
dfsch_object_t* value;
dfsch_object_t* slot;
DFSCH_OBJECT_ARG(j, value);
DFSCH_OBJECT_ARG(j, slot);
dfsch_slot_set(obj, slot, value, 1);
i = DFSCH_FAST_CDR(i);
}
while (DFSCH_PAIR_P(args)){
dfsch_object_t* keyword;
dfsch_object_t* value;
dfsch_object_t* slot;
keyword = DFSCH_FAST_CAR(args);
args = DFSCH_FAST_CDR(args);
if (!DFSCH_PAIR_P(args)){
dfsch_error("Value expected for keyword", keyword);
}
value = DFSCH_FAST_CAR(args);
args = DFSCH_FAST_CDR(args);
slot = dfsch_assq(keyword, klass->initargs);
if (!slot){
dfsch_error("Unknown keyword", keyword);
}
dfsch_slot_set(obj, dfsch_list_item(slot, 1), value, 1);
}
}
dfsch_object_t* dfsch_constant_expression_value(dfsch_object_t* expression,
dfsch_object_t* env){
if (DFSCH_SYMBOL_P(expression)){
if (!env){
return DFSCH_INVALID_OBJECT;
}
return dfsch_variable_constant_value(expression, env);
} else if (dfsch_quote_expression_p(expression)){
return DFSCH_FAST_CAR(expression);
} else if (DFSCH_PAIR_P(expression)){
return DFSCH_INVALID_OBJECT;
} else {
return expression;
}
}
static void build_args(dfsch_object_t* list, int* pargc, char*** pargv){
int alloc = 16;
char** argv = GC_MALLOC(sizeof(char*) * alloc);
int argc = 0;
while (DFSCH_PAIR_P(list)){
if (alloc <= argc){
alloc *= 2;
argv = GC_REALLOC(argv, sizeof(char*) * alloc);
}
argv[argc] = convert_arg(DFSCH_FAST_CAR(list));
argc++;
list = DFSCH_FAST_CDR(list);
}
*pargc = argc;
*pargv = argv;
}
char* dfsch_tcl_quote_list(dfsch_object_t* list){
dfsch_str_list_t* sl = dfsch_sl_create();
dfsch_object_t* i;
while (DFSCH_PAIR_P(list)){
dfsch_sl_append(sl, " ");
i = DFSCH_FAST_CAR(list);
if (dfsch_string_p(i)){
dfsch_sl_append(sl, dfsch_tcl_quote(dfsch_string_to_cstr(i)));
} else if (dfsch_keyword_p(i)){
dfsch_sl_append(sl, dfsch_saprintf("-%s", dfsch_symbol(i)));
} else if (DFSCH_PAIR_P(i)){
dfsch_sl_append(sl, dfsch_tcl_quote(dfsch_tcl_quote_list(i)));
} else {
dfsch_sl_append(sl, dfsch_tcl_quote(dfsch_object_2_string(i, 10, 1)));
}
list = DFSCH_FAST_CDR(list);
}
return dfsch_sl_value(sl);
}
static void finalize_slots_definition(class_t* klass,
dfsch_object_t* env,
dfsch_object_t* slot_definitions){
dfsch_object_t* i = slot_definitions;
while (DFSCH_PAIR_P(i)){
dfsch_object_t* slot_def = DFSCH_FAST_CAR(i);
if (DFSCH_PAIR_P(slot_def)){
dfsch_slot_t* slot =
find_direct_slot(klass,
dfsch_symbol(DFSCH_FAST_CAR(slot_def)));
slot_def = DFSCH_FAST_CDR(slot_def);
while (DFSCH_PAIR_P((slot_def))){
dfsch_object_t* keyword;
dfsch_object_t* value;
keyword = DFSCH_FAST_CAR(slot_def);
slot_def = DFSCH_FAST_CDR(slot_def);
if (!DFSCH_PAIR_P(slot_def)){
dfsch_error("Value expected for slot option", keyword);
}
value = DFSCH_FAST_CAR(slot_def);
slot_def = DFSCH_FAST_CDR(slot_def);
if(dfsch_compare_keyword(keyword, "accessor")){
dfsch_object_t* accessor =
dfsch__make_slot_accessor_for_slot(klass, slot);
dfsch_method_t* method =
dfsch_make_method(accessor, NULL, dfsch_cons(klass, NULL),
accessor);
dfsch_define_method(env, value, method);
} else if(dfsch_compare_keyword(keyword, "reader")){
dfsch_object_t* accessor =
dfsch__make_slot_reader_for_slot(klass, slot);
dfsch_method_t* method =
dfsch_make_method(accessor, NULL, dfsch_cons(klass, NULL),
accessor);
dfsch_define_method(env, value, method);
} else if(dfsch_compare_keyword(keyword, "write")){
dfsch_object_t* accessor =
dfsch__make_slot_writer_for_slot(klass, slot);
dfsch_method_t* method =
dfsch_make_method(accessor, NULL, dfsch_cons(klass, NULL),
accessor);
dfsch_define_method(env, value, method);
} else if(dfsch_compare_keyword(keyword, "initform")){
klass->initvalues = dfsch_cons(dfsch_list(2,
dfsch_eval(value, env),
slot),
klass->initvalues);
} else if(dfsch_compare_keyword(keyword, "initarg")){
klass->initargs = dfsch_cons(dfsch_list(2, value, slot),
klass->initargs);
} else if(dfsch_compare_keyword(keyword, "documentation")){
slot->documentation = dfsch_string_to_cstr(value);
}
}
}
i = DFSCH_FAST_CDR(i);
}
}
void dfsch_load(dfsch_object_t* env, char* name,
dfsch_object_t* path_list,
int as_toplevel){
struct stat st;
dfsch_object_t* path;
char *pathpart;
char *fname;
str_list_t* l;
int i;
for (i = 0; i < sizeof(builtin_modules) / sizeof(builtin_module_t); i++){
if (strcmp(builtin_modules[i].name, name) == 0){
builtin_modules[i].register_proc(env);
return;
}
}
if (path_list){
path = path_list;
} else {
path = dfsch_env_get_cstr(env, "*load-path*");
if (path == DFSCH_INVALID_OBJECT){
path = NULL;
}
}
while (DFSCH_PAIR_P(path)){
dfsch_object_t* pp = DFSCH_FAST_CAR(path);
if (!dfsch_string_p(pp)){
if (dfsch_apply(pp, dfsch_list(2,
env,
dfsch_make_string_cstr(name)))){
return;
}
path = DFSCH_FAST_CDR(path);
continue;
}
l = sl_create();
sl_append(l, dfsch_string_to_cstr(DFSCH_FAST_CAR(path)));
sl_append(l, "/");
sl_append(l, name);
pathpart = sl_value(l);
if (stat(pathpart, &st) == 0){
if (S_ISREG(st.st_mode) || S_ISLNK(st.st_mode)){
for (i = 0; i < sizeof(loaders) / sizeof(module_loader_t); i++){
if (strcmp(pathpart + strlen(pathpart) - strlen(loaders[i].path_ext),
loaders[i].path_ext) == 0){
loaders[i].load(pathpart, env, as_toplevel);
return;
}
}
dfsch_load_scm(env, pathpart, 0);
return;
}
}
for (i = 0; i < sizeof(loaders) / sizeof(module_loader_t); i++){
fname = stracat(pathpart, loaders[i].path_ext);
if (stat(fname, &st) == 0 && (S_ISREG(st.st_mode) ||
S_ISLNK(st.st_mode))){
loaders[i].load(fname, env, as_toplevel);
return;
}
}
path = dfsch_cdr(path);
}
dfsch_error("Module not found", dfsch_make_string_cstr(name));
}