void function_trace_print(Process *process) { printf(" ----------------------------------------------------------------\n"); for(int i = process->function_trace_pos - 1; i >= 0; i--) { printf("%3d ", i); StackTraceCallSite call_site = process->function_trace[i]; Obj *o = call_site.caller; Obj *function = call_site.callee; if(o->meta) { //printf("%s\n", obj_to_string(o->meta)->s); char *func_name = ""; Obj *func_name_data = NULL; if(function && function->meta) { func_name_data = env_lookup(process, function->meta, obj_new_keyword("name")); } if(func_name_data) { func_name = obj_to_string_not_prn(process, func_name_data)->s; } else { func_name = "???"; // obj_to_string(function)->s; } int line = env_lookup(process, o->meta, obj_new_keyword("line"))->i; int pos = env_lookup(process, o->meta, obj_new_keyword("pos"))->i; char *file_path = env_lookup(process, o->meta, obj_new_keyword("file"))->s; char *file = file_path; int len = (int)strlen(file_path); for(int i = len - 1; i >= 0; i--) { if(file_path[i] == '/') { file = strdup(file_path + i + 1); break; } } printf("%-30s %s %d:%d", func_name, file, line, pos); } else { printf("No meta data."); //"%s", obj_to_string(function)->s); } printf("\n"); } printf(" ----------------------------------------------------------------\n"); }
void print_generic_array_or_struct(Obj *total, Obj *type_lookup, struct Obj *arg_to_str_obj) { assert(total); assert(total->tag == 'S'); assert(type_lookup); assert(arg_to_str_obj); shadow_stack_push(total); shadow_stack_push(type_lookup); shadow_stack_push(arg_to_str_obj); Obj *reffed_arg_type = obj_list(obj_new_keyword("ref"), type_lookup); // HACK: ref needed when sending arrays into str Obj *args_type = obj_list(reffed_arg_type); Obj *signature = obj_list(obj_new_keyword("fn"), args_type, type_string); Obj *quoted_sig = obj_list(lisp_quote, signature); //printf("quoted_sig: %s\n", obj_to_string(quoted_sig)->s); Obj *call_to_generic_name = obj_list(obj_new_symbol("generic-name"), obj_new_string("str"), quoted_sig); shadow_stack_push(call_to_generic_name); Obj *generic_name_result = eval(global_env, call_to_generic_name); shadow_stack_push(generic_name_result); if(eval_error) { printf("Error when calling generic-name:\n"); printf("%s\n", obj_to_string(eval_error)->s); return; } else { //printf("Generic name: %s\n", obj_to_string_not_prn(generic_name_result)->s); } // Also make sure this particular version of the str primop has been baked: Obj *call_to_bake_generic_primop_auto = obj_list(obj_new_symbol("bake-generic-primop-auto"), obj_new_string("str"), quoted_sig); shadow_stack_push(call_to_bake_generic_primop_auto); eval(global_env, call_to_bake_generic_primop_auto); if(eval_error) { printf("Error when calling bake-generic-primop-auto from print_generic_array_or_struct:\n"); printf("%s\n", obj_to_string(eval_error)->s); function_trace_print(); return; } else { //printf("%s should now exists\n", obj_to_string_not_prn(generic_name_result)->s); } char *generic_name = obj_to_string_not_prn(generic_name_result)->s; //printf("generic_name 1: %s\n", generic_name); Obj *call_to_str = obj_list(obj_new_symbol(generic_name), (struct Obj *)arg_to_str_obj); // OBS!!! // // Calling obj_to_string on the call_to_str form will result in an infinite loop: // printf("Call to str: %s\n", obj_to_string(call_to_str)->s); // // DON'T DO IT!!! shadow_stack_push(call_to_str); Obj *array_to_string_result = eval(global_env, call_to_str); shadow_stack_push(array_to_string_result); if(eval_error) { printf("Error when calling str function for void ptr of type '%s':\n", obj_to_string(type_lookup)->s); printf("%s\n", obj_to_string(eval_error)->s); assert(false); stack_pop(); obj_string_mut_append(total, "FAIL"); return; } obj_string_mut_append(total, obj_to_string_not_prn(array_to_string_result)->s); Obj *pop1 = shadow_stack_pop(); assert(pop1 == array_to_string_result); shadow_stack_pop(); shadow_stack_pop(); shadow_stack_pop(); shadow_stack_pop(); shadow_stack_pop(); shadow_stack_pop(); Obj *pop8 = shadow_stack_pop(); assert(pop8 == total); return; }
void obj_to_string_internal(Obj *total, const Obj *o, bool prn, int indent) { assert(o); int x = indent; if(o->tag == 'C') { obj_string_mut_append(total, "("); x++; int save_x = x; const Obj *p = o; while(p && p->car) { obj_to_string_internal(total, p->car, true, x); if(p->cdr && p->cdr->tag != 'C') { obj_string_mut_append(total, " . "); obj_to_string_internal(total, o->cdr, true, x); break; } else if(p->cdr && p->cdr->car) { if(/* p->car->tag == 'C' || */p->car->tag == 'E') { obj_string_mut_append(total, "\n"); x = save_x; add_indentation(total, x); } else { obj_string_mut_append(total, " "); x++; } } p = p->cdr; } obj_string_mut_append(total, ")"); x++; } else if(o->tag == 'A') { //printf("Will print Obj Array with count %d\n", o->count); shadow_stack_push((struct Obj *)o); x++; //int save_x = x; obj_string_mut_append(total, "["); for(int i = 0; i < o->count; i++) { obj_to_string_internal(total, o->array[i], true, x); if(i < o->count - 1) { /* if(o->array[i]->car->tag == 'Q' || o->array[i]->car->tag == 'E') { */ /* obj_string_mut_append(total, "\n"); */ /* x = save_x; */ /* add_indentation(total, x); */ /* } */ /* else { */ /* obj_string_mut_append(total, " "); */ /* x++; */ /* } */ obj_string_mut_append(total, " "); } } obj_string_mut_append(total, "]"); shadow_stack_pop(); x++; } else if(o->tag == 'E') { shadow_stack_push((struct Obj *)o); obj_string_mut_append(total, "{"); x++; Obj *p = o->bindings; while(p && p->car) { char *key_s = obj_to_string(p->car->car)->s; obj_string_mut_append(total, key_s); obj_string_mut_append(total, " "); obj_to_string_internal(total, p->car->cdr, true, x + (int)strlen(key_s) + 1); p = p->cdr; if(p && p->car && p->car->car) { obj_string_mut_append(total, ", \n"); add_indentation(total, x); } } obj_string_mut_append(total, "}"); if(o->parent) { obj_string_mut_append(total, " -> \n"); Obj *parent_printout = obj_to_string(o->parent); obj_string_mut_append(total, parent_printout->s); } shadow_stack_pop(); } else if(o->tag == 'I') { static char temp[64]; snprintf(temp, 64, "%d", o->i); obj_string_mut_append(total, temp); } else if(o->tag == 'V') { static char temp[64]; snprintf(temp, 64, "%f", o->f32); obj_string_mut_append(total, temp); obj_string_mut_append(total, "f"); } else if(o->tag == 'W') { static char temp[64]; snprintf(temp, 64, "%f", o->f64); obj_string_mut_append(total, temp); } else if(o->tag == 'S') { if(prn) { obj_string_mut_append(total, "\""); } obj_string_mut_append(total, o->s); if(prn) { obj_string_mut_append(total, "\""); } } else if(o->tag == 'Y') { obj_string_mut_append(total, o->s); } else if(o->tag == 'K') { obj_string_mut_append(total, ":"); obj_string_mut_append(total, o->s); } else if(o->tag == 'P') { obj_string_mut_append(total, "<primop:"); static char temp[256]; snprintf(temp, 256, "%p", o->primop); obj_string_mut_append(total, temp); if(o->meta) { Obj *name = env_lookup(o->meta, obj_new_keyword("name")); if(name) { obj_string_mut_append(total, ":"); obj_string_mut_append(total, obj_to_string_not_prn(name)->s); } } obj_string_mut_append(total, ">"); } else if(o->tag == 'D') { obj_string_mut_append(total, "<dylib:"); static char temp[256]; snprintf(temp, 256, "%p", o->primop); obj_string_mut_append(total, temp); obj_string_mut_append(total, ">"); } else if(o->tag == 'Q') { shadow_stack_push((struct Obj *)o); Obj *type_lookup; if(o->meta && (type_lookup = env_lookup(o->meta, obj_new_keyword("type")))) { if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(type_lookup->car, obj_new_keyword("Array"))) { print_generic_array_or_struct(total, type_lookup, (struct Obj *)o); } else { print_generic_array_or_struct(total, type_lookup, (struct Obj *)o); /* obj_string_mut_append(total, "<ptr"); */ /* obj_string_mut_append(total, obj_to_string(type_lookup)->s); */ /* obj_string_mut_append(total, ">"); */ } } else { obj_string_mut_append(total, "<ptr:"); static char temp[256]; snprintf(temp, 256, "%p", o->primop); obj_string_mut_append(total, temp); obj_string_mut_append(total, " of unknown type"); obj_string_mut_append(total, ">"); } shadow_stack_pop(); } else if(o->tag == 'F') { obj_string_mut_append(total, "<ffi:"); static char temp[256]; snprintf(temp, 256, "%p", o->funptr); obj_string_mut_append(total, temp); if(o->meta) { Obj *name = env_lookup(o->meta, obj_new_keyword("name")); if(name) { obj_string_mut_append(total, ":"); obj_string_mut_append(total, obj_to_string_not_prn(name)->s); } } else { } obj_string_mut_append(total, ">"); } else if(o->tag == 'L') { if(setting_print_lambda_body) { obj_string_mut_append(total, "(fn"); obj_string_mut_append(total, " "); obj_string_mut_append(total, obj_to_string(o->params)->s); obj_string_mut_append(total, " "); obj_string_mut_append(total, obj_to_string(o->body)->s); obj_string_mut_append(total, ")"); } else { obj_string_mut_append(total, "<lambda>"); } } else if(o->tag == 'M') { if(setting_print_lambda_body) { obj_string_mut_append(total, "(macro"); obj_string_mut_append(total, " "); obj_string_mut_append(total, obj_to_string(o->params)->s); obj_string_mut_append(total, " "); obj_string_mut_append(total, obj_to_string(o->body)->s); obj_string_mut_append(total, ")"); } else { obj_string_mut_append(total, "<macro>"); } } else if(o->tag == 'T') { char s[2] = { o->character, '\0' }; if(prn) { obj_string_mut_append(total, "\\"); } obj_string_mut_append(total, s); } else if(o->tag == 'B') { if(o->boolean) { obj_string_mut_append(total, "true"); } else { obj_string_mut_append(total, "false"); } } else { printf("obj_to_string() can't handle type tag %c (%d).\n", o->tag, o->tag); assert(false); } }
void env_extend_with_args(Process *process, Obj *calling_env, Obj *function, int arg_count, Obj **args, bool allow_restargs) { // TODO: remove the whole 'C' branch and only allow arrays for parameters Obj *paramp = function->params; if(paramp->tag == 'C') { for(int i = 0; i < arg_count; i++) { if(allow_restargs && obj_eq(process, paramp->car, dotdotdot)) { printf("Found dotdotdot\n"); if(paramp->cdr->car) { int rest_count = arg_count - i; printf("Rest count: %d\n", rest_count); Obj *rest_array = obj_new_array(rest_count); for(int j = 0; j < rest_count; j++) { rest_array->array[j] = args[i + j]; } env_extend(calling_env, paramp->cdr->car, rest_array); return; } else { printf("No arguments after dotdotdot\n"); return; } } if(!paramp || !paramp->car) { set_error("Too many arguments (C) to function: ", function); } env_extend(calling_env, paramp->car, args[i]); paramp = paramp->cdr; } if(paramp && paramp->cdr) { set_error("Too few arguments to function: ", function); } } else if(paramp->tag == 'A') { int i = 0; for(; i < arg_count; i++) { if(allow_restargs && obj_eq(process, paramp->array[i], dotdotdot)) { int rest_count = arg_count - i; Obj *rest_list = obj_new_cons(NULL, NULL); Obj *last = rest_list; for(int j = 0; j < rest_count; j++) { Obj *new_element = args[i + j]; last->car = new_element; Obj *new_last = obj_new_cons(NULL, NULL); last->cdr = new_last; last = new_last; } env_extend(calling_env, paramp->array[i + 1], rest_list); return; } env_extend(calling_env, paramp->array[i], args[i]); } if(i < paramp->count) { if(allow_restargs && obj_eq(process, paramp->array[i], dotdotdot)) { env_extend(calling_env, paramp->array[i + 1], obj_new_array(0)); } else { set_error("Too few arguments to function/macro: ", function); } } if(arg_count > paramp->count) { printf("arguments: %s\n", obj_to_string(process, paramp)->s); //printf("meta: %s\n", (function->meta ? obj_to_string(process, function->meta)->s : "NULL")); Obj *name = function; if(function->meta) { Obj *name_lookup = env_lookup(process, function->meta, obj_new_keyword("name")); if(name_lookup) { name = name_lookup; } } set_error("Too many arguments (A) to function/macro: ", name); } } }
void print_generic_array_or_struct(Process *process, Obj *total, Obj *type_lookup, struct Obj *arg_to_str_obj) { assert(total); assert(total->tag == 'S'); assert(type_lookup); assert(arg_to_str_obj); shadow_stack_push(process, total); shadow_stack_push(process, type_lookup); shadow_stack_push(process, arg_to_str_obj); Obj *reffed_arg_type = obj_list(obj_new_keyword("ref"), type_lookup); // HACK: ref needed when sending arrays into str Obj *args_type = obj_list(reffed_arg_type); Obj *signature = obj_list(obj_new_keyword("fn"), args_type, type_string); Obj *quoted_sig = obj_list(lisp_quote, signature); //printf("quoted_sig: %s\n", obj_to_string(quoted_sig)->s); Obj *generic_name_result = generic_name(process, "prn", quoted_sig); if(eval_error) { return; } shadow_stack_push(process, generic_name_result); bake_generic_primop_auto(process, "prn", quoted_sig); if(eval_error) { return; } // TODO: why this conversion? char *generic_name = obj_to_string_not_prn(process, generic_name_result)->s; //printf("generic_name 1: %s\n", generic_name); Obj *call_to_str = obj_list(obj_new_symbol(generic_name), (struct Obj *)arg_to_str_obj); // OBS!!! // // Calling obj_to_string on the call_to_str form will result in an infinite loop: // printf("Call to str: %s\n", obj_to_string(call_to_str)->s); // // DON'T DO IT!!! shadow_stack_push(process, call_to_str); Obj *array_to_string_result = NULL; if(BYTECODE_EVAL) { array_to_string_result = bytecode_sub_eval_form(process, process->global_env, call_to_str); } else { array_to_string_result = eval(process, process->global_env, call_to_str); } shadow_stack_push(process, array_to_string_result); if(eval_error) { printf("Error when calling str function for void ptr of type '%s':\n", obj_to_string(process, type_lookup)->s); printf("%s\n", obj_to_string(process, eval_error)->s); assert(false); stack_pop(process); obj_string_mut_append(total, "FAIL"); return; } obj_string_mut_append(total, obj_to_string_not_prn(process, array_to_string_result)->s); Obj *pop1 = shadow_stack_pop(process); assert(pop1 == array_to_string_result); shadow_stack_pop(process); shadow_stack_pop(process); shadow_stack_pop(process); shadow_stack_pop(process); Obj *pop8 = shadow_stack_pop(process); assert(pop8 == total); return; }
void obj_to_string_internal(Process *process, Obj *total, const Obj *o, bool prn, int indent) { assert(o); int x = indent; if(o->tag == 'C') { obj_string_mut_append(total, "("); x++; int save_x = x; const Obj *p = o; while(p && p->car) { obj_to_string_internal(process, total, p->car, true, x); if(p->cdr && p->cdr->tag != 'C') { obj_string_mut_append(total, " . "); obj_to_string_internal(process, total, o->cdr, true, x); break; } else if(p->cdr && p->cdr->car) { if(/* p->car->tag == 'C' || */ p->car->tag == 'E') { obj_string_mut_append(total, "\n"); x = save_x; add_indentation(total, x); } else { obj_string_mut_append(total, " "); x++; } } p = p->cdr; } obj_string_mut_append(total, ")"); x++; } else if(o->tag == 'A') { //printf("Will print Obj Array with count %d\n", o->count); shadow_stack_push(process, (struct Obj *)o); x++; //int save_x = x; obj_string_mut_append(total, "["); for(int i = 0; i < o->count; i++) { obj_to_string_internal(process, total, o->array[i], true, x); if(i < o->count - 1) { /* if(o->array[i]->car->tag == 'Q' || o->array[i]->car->tag == 'E') { */ /* obj_string_mut_append(total, "\n"); */ /* x = save_x; */ /* add_indentation(total, x); */ /* } */ /* else { */ /* obj_string_mut_append(total, " "); */ /* x++; */ /* } */ obj_string_mut_append(total, " "); } } obj_string_mut_append(total, "]"); shadow_stack_pop(process); x++; } else if(o->tag == 'E') { shadow_stack_push(process, (struct Obj *)o); if(o == process->global_env) { obj_string_mut_append(total, "{ GLOBAL ENVIRONMENT }"); return; } obj_string_mut_append(total, "{"); x++; Obj *p = o->bindings; while(p && p->car) { char *key_s = obj_to_string(process, p->car->car)->s; obj_string_mut_append(total, key_s); obj_string_mut_append(total, " "); obj_to_string_internal(process, total, p->car->cdr, true, x + (int)strlen(key_s) + 1); p = p->cdr; if(p && p->car && p->car->car) { obj_string_mut_append(total, ", \n"); add_indentation(total, x); } } obj_string_mut_append(total, "}"); if(o->parent) { obj_string_mut_append(total, " -> \n"); Obj *parent_printout = obj_to_string(process, o->parent); obj_string_mut_append(total, parent_printout->s); } shadow_stack_pop(process); } else if(o->tag == 'I') { static char temp[64]; snprintf(temp, 64, "%d", o->i); obj_string_mut_append(total, temp); } else if(o->tag == 'V') { static char temp[64]; snprintf(temp, 64, "%f", o->f32); obj_string_mut_append(total, temp); obj_string_mut_append(total, "f"); } else if(o->tag == 'W') { static char temp[64]; snprintf(temp, 64, "%f", o->f64); obj_string_mut_append(total, temp); } else if(o->tag == 'S') { if(prn) { obj_string_mut_append(total, "\""); } obj_string_mut_append(total, o->s); if(prn) { obj_string_mut_append(total, "\""); } } else if(o->tag == 'Y') { obj_string_mut_append(total, o->s); } else if(o->tag == 'K') { obj_string_mut_append(total, ":"); obj_string_mut_append(total, o->s); } else if(o->tag == 'P') { obj_string_mut_append(total, "<primop:"); static char temp[256]; snprintf(temp, 256, "%p", o->primop); obj_string_mut_append(total, temp); if(o->meta) { Obj *name = env_lookup(process, o->meta, obj_new_keyword("name")); if(name) { obj_string_mut_append(total, ":"); obj_string_mut_append(total, obj_to_string_not_prn(process, name)->s); } } obj_string_mut_append(total, ">"); } else if(o->tag == 'D') { obj_string_mut_append(total, "<dylib:"); static char temp[256]; snprintf(temp, 256, "%p", o->primop); obj_string_mut_append(total, temp); obj_string_mut_append(total, ">"); } else if(o->tag == 'Q') { shadow_stack_push(process, (struct Obj *)o); Obj *type_lookup; if(o->meta && (type_lookup = env_lookup(process, o->meta, obj_new_keyword("type")))) { if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(process, type_lookup->car, obj_new_keyword("Array"))) { print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)o); } else { print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)o); /* obj_string_mut_append(total, "<ptr"); */ /* obj_string_mut_append(total, obj_to_string(type_lookup)->s); */ /* obj_string_mut_append(total, ">"); */ } } else { obj_string_mut_append(total, "<ptr:"); static char temp[256]; snprintf(temp, 256, "%p", o->primop); obj_string_mut_append(total, temp); obj_string_mut_append(total, " of unknown type"); obj_string_mut_append(total, ">"); } shadow_stack_pop(process); } else if(o->tag == 'R') { shadow_stack_push(process, (struct Obj *)o); if(!o->void_ptr) { eval_error = obj_new_string("Pointer to global is NULL.\n"); return; } Obj *type_lookup; //printf("o %p %p\n", o, o->void_ptr); if(o->void_ptr == NULL) { obj_string_mut_append(total, "NULL"); } else if(o->meta && (type_lookup = env_lookup(process, o->meta, obj_new_keyword("type")))) { //printf("type %s\n", obj_to_string(type_lookup)->s); if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(process, type_lookup->car, obj_new_keyword("Array"))) { void *dereffed = *(void **)o->void_ptr; assert(dereffed); Obj *x = primitive_to_obj(process, dereffed, type_lookup); shadow_stack_push(process, x); obj_string_mut_append(total, obj_to_string(process, x)->s); shadow_stack_pop(process); // x } else if(obj_eq(process, type_lookup, type_int)) { //int i = 123; void *dereffed = *(void **)o->void_ptr; assert(dereffed); Obj *x = primitive_to_obj(process, dereffed, type_int); obj_string_mut_append(total, obj_to_string(process, x)->s); } else if(obj_eq(process, type_lookup, type_float)) { //int i = 123; void *dereffed = *(void **)o->void_ptr; assert(dereffed); Obj *x = primitive_to_obj(process, dereffed, type_float); obj_string_mut_append(total, obj_to_string(process, x)->s); } else if(obj_eq(process, type_lookup, type_double)) { void *dereffed = *(void **)o->void_ptr; assert(dereffed); Obj *x = primitive_to_obj(process, dereffed, type_double); obj_string_mut_append(total, obj_to_string(process, x)->s); } else if(obj_eq(process, type_lookup, type_bool)) { void *dereffed = *(void **)o->void_ptr; // can't assert since false == NULL Obj *x = primitive_to_obj(process, dereffed, type_bool); obj_string_mut_append(total, obj_to_string(process, x)->s); } else if(obj_eq(process, type_lookup, type_string)) { void *dereffed = *(void **)o->void_ptr; assert(dereffed); Obj *x = primitive_to_obj(process, dereffed, type_string); obj_string_mut_append(total, x->s); } else if(obj_eq(process, type_lookup, type_char)) { void *dereffed = *(void **)o->void_ptr; assert(dereffed); Obj *x = primitive_to_obj(process, dereffed, type_char); obj_string_mut_append(total, obj_to_string(process, x)->s); } else { void *dereffed = *(void **)o->void_ptr; assert(dereffed); Obj *x = primitive_to_obj(process, dereffed, type_lookup); print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)x); /* obj_string_mut_append(total, "<ptr"); */ /* obj_string_mut_append(total, obj_to_string(type_lookup)->s); */ /* obj_string_mut_append(total, ">"); */ } } obj_string_mut_append(total, " ; ptr-to-global"); shadow_stack_pop(process); } else if(o->tag == 'F') { obj_string_mut_append(total, "<ffi:"); static char temp[256]; snprintf(temp, 256, "%p", o->funptr); obj_string_mut_append(total, temp); if(o->meta) { Obj *name = env_lookup(process, o->meta, obj_new_keyword("name")); if(name) { obj_string_mut_append(total, ":"); obj_string_mut_append(total, obj_to_string_not_prn(process, name)->s); } } else { } obj_string_mut_append(total, ">"); } else if(o->tag == 'L') { if(setting_print_lambda_body) { obj_string_mut_append(total, "(fn"); obj_string_mut_append(total, " "); obj_string_mut_append(total, obj_to_string(process, o->params)->s); obj_string_mut_append(total, " "); obj_string_mut_append(total, obj_to_string(process, o->body)->s); obj_string_mut_append(total, ")"); } else { obj_string_mut_append(total, "<lambda>"); } } else if(o->tag == 'M') { if(setting_print_lambda_body) { obj_string_mut_append(total, "(macro"); obj_string_mut_append(total, " "); obj_string_mut_append(total, obj_to_string(process, o->params)->s); obj_string_mut_append(total, " "); obj_string_mut_append(total, obj_to_string(process, o->body)->s); obj_string_mut_append(total, ")"); } else { obj_string_mut_append(total, "<macro>"); } } else if(o->tag == 'T') { char s[2] = {o->character, '\0'}; if(prn) { obj_string_mut_append(total, "\\"); } obj_string_mut_append(total, s); } else if(o->tag == 'B') { if(o->boolean) { obj_string_mut_append(total, "true"); } else { obj_string_mut_append(total, "false"); } } else if(o->tag == 'X') { obj_string_mut_append(total, "(\n"); for(char *p = o->bytecode; *p != '\0';) { const int buffer_size = 128; char buffer[buffer_size]; snprintf(buffer, buffer_size, "%4d ", (int)(p - o->bytecode)); obj_string_mut_append(total, buffer); char c = *p; p++; if(c == 'l') { snprintf(buffer, buffer_size, "LOAD LIT %d", *((int*)p)); p += sizeof(int); } else if(c == 'a') { snprintf(buffer, buffer_size, "LOAD λ %d", *((int*)p)); p += sizeof(int); } else if(c == 'c') { snprintf(buffer, buffer_size, "CALL %d", *((int*)p)); p += sizeof(int); } else if(c == 'd') { snprintf(buffer, buffer_size, "DEFINE %d", *((int*)p)); p += sizeof(int); } else if(c == 'y') { snprintf(buffer, buffer_size, "LOOKUP %d", *((int*)p)); p += sizeof(int); } else if(c == 'i') { snprintf(buffer, buffer_size, "JUMP IF NOT %d", *((int*)p)); p += sizeof(int); } else if(c == 'j') { snprintf(buffer, buffer_size, "JUMP %d", *((int*)p)); p += sizeof(int); } else if(c == 'r') { snprintf(buffer, buffer_size, "RESET %d", *((int*)p)); p += sizeof(int); } else if(c == 't') { snprintf(buffer, buffer_size, "LET %d", *((int*)p)); p += sizeof(int); } else if(c == 'e') { snprintf(buffer, buffer_size, "DISCARD"); } else if(c == 'g') { snprintf(buffer, buffer_size, "CATCH"); } else if(c == 'n') { snprintf(buffer, buffer_size, "NOT"); } else if(c == 'p') { snprintf(buffer, buffer_size, "PUSH NIL"); } else if(c == 'v') { snprintf(buffer, buffer_size, "POP LET-SCOPE"); } else if(c == 'x') { snprintf(buffer, buffer_size, "DIRECT LOOKUP"); } else if(c == 'q') { snprintf(buffer, buffer_size, "END"); } else { snprintf(buffer, buffer_size, "UNHANDLED OP (%c)", *p); p++; } obj_string_mut_append(total, buffer); obj_string_mut_append(total, "\n"); } obj_string_mut_append(total, "Literals: "); obj_string_mut_append(total, obj_to_string(process, o->bytecode_literals)->s); obj_string_mut_append(total, "\n"); obj_string_mut_append(total, ")"); } else { printf("obj_to_string() can't handle type tag %c (%d).\n", o->tag, o->tag); assert(false); } }
void call_struct_constructor(Process *process, Obj *function, Obj **args, int arg_count) { // Evaluation of a struct-definition (a dictionary) in function position (which means that it is used as a constructor) Obj *name_obj = env_lookup(process, function, obj_new_keyword("name")); assert_or_set_error(name_obj, "no key 'name' on struct definition: ", function); char *name = name_obj->s; Obj *struct_size_obj = env_lookup(process, function, obj_new_keyword("size")); assert_or_set_error(struct_size_obj, "no key 'size' on struct definition: ", function); int struct_size = struct_size_obj->i; Obj *struct_member_count_obj = env_lookup(process, function, obj_new_keyword("member-count")); assert_or_set_error(struct_member_count_obj, "no key 'member-count' on struct definition: ", function); int member_count = struct_member_count_obj->i; Obj *offsets_obj = env_lookup(process, function, obj_new_keyword("member-offsets")); assert_or_set_error(offsets_obj, "no key 'member-offsets' on struct definition: ", function); assert_or_set_error(offsets_obj->tag == 'A', "offsets must be an array: ", function); Obj **offsets = offsets_obj->array; Obj *member_types_obj = env_lookup(process, function, obj_new_keyword("member-types")); assert_or_set_error(member_types_obj, "no key 'member-types' on struct definition: ", function); assert_or_set_error(member_types_obj->tag == 'A', "member-types must be an array: ", function); Obj **member_types = member_types_obj->array; //printf("Will create a %s of size %d and member count %d.\n", name, size, member_count); void *p = malloc(struct_size); Obj *new_struct = obj_new_ptr(p); shadow_stack_push(process, new_struct); if(!new_struct->meta) { new_struct->meta = obj_new_environment(NULL); } env_assoc(process, new_struct->meta, obj_new_keyword("type"), obj_new_keyword(name)); assert_or_set_error(!(arg_count < member_count), "Too few args to struct constructor: ", obj_new_string(name)); assert_or_set_error(!(arg_count > member_count), "Too many args to struct constructor: ", obj_new_string(name)); for(int i = 0; i < arg_count; i++) { Obj *member_type = member_types[i]; int offset = offsets[i]->i; if(args[i]->tag == 'V') { assert_or_set_error(obj_eq(process, member_type, type_float), "Can't assign float to a member of type ", obj_to_string(process, member_type)); float *fp = (float *)(((char *)new_struct->void_ptr) + offset); float f = args[i]->f32; //printf("Setting member %d at offset %d to %f.\n", i, offset, f); *fp = f; } else if(args[i]->tag == 'I') { assert_or_set_error(obj_eq(process, member_type, type_int), "Can't assign int to a member of type ", obj_to_string(process, member_type)); int *xp = (int *)(((char *)new_struct->void_ptr) + offset); int x = args[i]->i; *xp = x; } else if(args[i]->tag == 'B') { assert_or_set_error(obj_eq(process, member_type, type_bool), "Can't assign bool to a member of type ", obj_to_string(process, member_type)); bool *xp = (bool *)(((char *)new_struct->void_ptr) + offset); bool x = args[i]->boolean; *xp = x; } else if(args[i]->tag == 'Q') { assert_or_set_error(!obj_eq(process, member_type, type_char), "Can't assign char to a member of type ", obj_to_string(process, member_type)); assert_or_set_error(!obj_eq(process, member_type, type_int), "Can't assign int to a member of type ", obj_to_string(process, member_type)); assert_or_set_error(!obj_eq(process, member_type, type_float), "Can't assign float to a member of type ", obj_to_string(process, member_type)); assert_or_set_error(!obj_eq(process, member_type, type_string), "Can't assign string to a member of type ", obj_to_string(process, member_type)); void **vp = (void **)(((char *)new_struct->void_ptr) + offset); *vp = args[i]->void_ptr; } else if(args[i]->tag == 'S') { assert_or_set_error(obj_eq(process, member_type, type_string), "Can't assign int to a member of type ", obj_to_string(process, member_type)); char **sp = (char **)(((char *)new_struct->void_ptr) + offset); *sp = strdup(args[i]->s); // must strdup or the struct will ref Obj's on the stack that will get gc:ed } else if(args[i]->tag == 'T') { assert_or_set_error(obj_eq(process, member_type, type_char), "Can't assign char to a member of type ", obj_to_string(process, member_type)); char *cp = (char *)(((char *)new_struct->void_ptr) + offset); *cp = args[i]->character; } else if(args[i]->tag == 'A') { //assert_or_set_error(obj_eq(member_type, type_array), "Can't assign array to a member of type ", obj_to_string(member_type)); // TODO: use this code for sending arrays to normal FFI functions too!!! // TODO: use the SAME code for sending data to FFI and struct constructors. // TODO: check that we send the expected type to the constructor Array *a = obj_array_to_carp_array(process, args[i]); if(!a) { return; } void **ap = (void **)(((char *)new_struct->void_ptr) + offset); *ap = a; } else { eval_error = obj_new_string("Can't set member "); char buffer[32]; sprintf(buffer, "%d", i); obj_string_mut_append(eval_error, buffer); obj_string_mut_append(eval_error, " of struct "); obj_string_mut_append(eval_error, name); obj_string_mut_append(eval_error, " to "); obj_string_mut_append(eval_error, obj_to_string(process, args[i])->s); obj_string_mut_append(eval_error, " (handled type)."); return; } } shadow_stack_pop(process); // pop new_struct stack_push(process, new_struct); }
void apply(Process *process, Obj *function, Obj **args, int arg_count) { if(function->tag == 'L') { //printf("Calling lambda "); obj_print_cout(function); printf(" with params: "); obj_print_cout(function->params); printf("\n"); //printf("Applying %s with arg count %d\n", obj_to_string(process, function)->s, arg_count); #if BYTECODE_EVAL Obj *calling_env = obj_new_environment(function->env); bool allow_rest_args = true; env_extend_with_args(process, calling_env, function, arg_count, args, allow_rest_args); //printf("calling_env: %s\n", obj_to_string(process, calling_env)->s); shadow_stack_push(process, function); shadow_stack_push(process, calling_env); /* printf("before\n"); */ /* shadow_stack_print(process); */ Obj *result = bytecode_sub_eval_internal(process, calling_env, function->body); if(eval_error) { return; } assert(result); //printf("result = %s\n", obj_to_string(process, result)->s); stack_push(process, result); // put it back on stack (TODO: fix this unnecessary work?) /* printf("after\n"); */ /* shadow_stack_print(process); */ Obj *pop1 = shadow_stack_pop(process); Obj *pop2 = shadow_stack_pop(process); assert(pop1 == calling_env); assert(pop2 == function); #else Obj *calling_env = obj_new_environment(function->env); bool allow_rest_args = true; env_extend_with_args(process, calling_env, function, arg_count, args, allow_rest_args); //printf("Lambda env: %s\n", obj_to_string(calling_env)->s); shadow_stack_push(process, function); shadow_stack_push(process, calling_env); if(function->body->tag == 'X') { eval_error = obj_new_string("Can't apply lambda with bytecode body."); } else { eval_internal(process, calling_env, function->body); } if(eval_error) { return; } Obj *pop1 = shadow_stack_pop(process); Obj *pop2 = shadow_stack_pop(process); assert(pop1 == calling_env); assert(pop2 == function); #endif } else if(function->tag == 'P') { Obj *result = function->primop((struct Process *)process, args, arg_count); stack_push(process, result); } else if(function->tag == 'F') { call_foreign_function(process, function, args, arg_count); } else if(function->tag == 'K') { if(arg_count != 1) { eval_error = obj_new_string("Args to keyword lookup must be a single arg."); } else if(args[0]->tag != 'E') { eval_error = obj_new_string("Arg 0 to keyword lookup must be a dictionary: "); obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); } else { Obj *value = env_lookup(process, args[0], function); if(value) { stack_push(process, value); } else { eval_error = obj_new_string("Failed to lookup keyword '"); obj_string_mut_append(eval_error, obj_to_string(process, function)->s); obj_string_mut_append(eval_error, "'"); obj_string_mut_append(eval_error, " in \n"); obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); obj_string_mut_append(eval_error, "\n"); } } } else if(function->tag == 'E' && obj_eq(process, env_lookup(process, function, obj_new_keyword("struct")), lisp_true)) { //printf("Calling struct: %s\n", obj_to_string(process, function)->s); if(obj_eq(process, env_lookup(process, function, obj_new_keyword("generic")), lisp_true)) { //printf("Calling generic struct constructor.\n"); Obj *function_call_symbol = obj_new_symbol("dynamic-generic-constructor-call"); shadow_stack_push(process, function_call_symbol); Obj **copied_args = malloc(sizeof(Obj *) * arg_count); for(int i = 0; i < arg_count; i++) { copied_args[i] = obj_copy(process, args[i]); if(args[i]->meta) { copied_args[i]->meta = obj_copy(process, args[i]->meta); } } Obj *carp_array = obj_new_array(arg_count); carp_array->array = copied_args; Obj *call_to_concretize_struct = obj_list(function_call_symbol, function, carp_array); shadow_stack_push(process, call_to_concretize_struct); eval_internal(process, process->global_env, call_to_concretize_struct); shadow_stack_pop(process); shadow_stack_pop(process); } else { call_struct_constructor(process, function, args, arg_count); } } else { set_error("Can't call non-function: ", function); } }
void call_foreign_function(Process *process, Obj *function, Obj **args, int arg_count) { assert(function); if(!function->funptr) { eval_error = obj_new_string("Can't call foregin function, it's funptr is NULL. May be a stub function with just a signature?"); return; } assert(function->cif); assert(function->arg_types); assert(function->return_type); // TODO: change name to 'arg_values' or something like that void **values = calloc(sizeof(void*), arg_count); assert(values); #define assert_or_free_values_and_set_error(assertion, message, object) \ if(!(assertion)) { \ free(values); \ } \ assert_or_set_error((assertion), (message), (object)); Obj *p = function->arg_types; for(int i = 0; i < arg_count; i++) { if(p && p->cdr) { assert(p->car); Obj *type_obj = p->car; // Handle ref types by unwrapping them: (:ref x) -> x if(type_obj->tag == 'C' && type_obj->car && type_obj->cdr && type_obj->cdr->car && obj_eq(process, type_obj->car, type_ref)) { type_obj = type_obj->cdr->car; // the second element of the list } args[i]->given_to_ffi = true; // This makes the GC ignore this value when deleting internal C-data, like inside a string if(obj_eq(process, type_obj, type_int)) { assert_or_free_values_and_set_error(args[i]->tag == 'I', "Invalid (expected int) type of arg: ", args[i]); values[i] = &args[i]->i; } else if(obj_eq(process, type_obj, type_bool)) { assert_or_free_values_and_set_error(args[i]->tag == 'B', "Invalid (expected bool) type of arg: ", args[i]); bool b = args[i]->boolean; values[i] = &b; } else if(obj_eq(process, type_obj, type_char)) { assert_or_free_values_and_set_error(args[i]->tag == 'T', "Invalid (expected char) type of arg: ", args[i]); char c = args[i]->character; values[i] = &c; } else if(obj_eq(process, type_obj, type_float)) { assert_or_free_values_and_set_error(args[i]->tag == 'V', "Invalid (expected float) type of arg: ", args[i]); values[i] = &args[i]->f32; } else if(obj_eq(process, type_obj, type_double)) { assert_or_free_values_and_set_error(args[i]->tag == 'W', "Invalid (expected double) type of arg: ", args[i]); values[i] = &args[i]->f64; } else if(obj_eq(process, type_obj, type_string)) { assert_or_free_values_and_set_error(args[i]->tag == 'S', "Invalid (expected string) type of arg: ", args[i]); //args[i]->s = strdup(args[i]->s); // OBS! Duplicating string here. TODO: Think about if this is the correct thing to do! values[i] = &args[i]->s; } else { //printf("Calling function with expected parameter of type %s. Argument is of type %c.\n", obj_to_string(process, p->car)->s, args[i]->tag); if(args[i]->tag == 'Q' /* || args[i]->tag == 'R' */) { #ifdef CHECKING if(args[i]->void_ptr == NULL || obj_eq(type_obj, obj_new_keyword("any"))) { goto hack; } assert_or_free_values_and_set_error(args[i]->meta, "Argument is missing meta data: ", args[i]); Obj *meta_type_tag = env_lookup(args[i]->meta, obj_new_keyword("type")); // TODO: make this keyword to a "singleton" assert_or_free_values_and_set_error(meta_type_tag, "Argument is missing meta 'type' tag: ", args[i]); bool eq = obj_eq(meta_type_tag, type_obj); if(!eq) { eval_error = obj_new_string("Invalid type of argument sent to function expecting '"); obj_string_mut_append(eval_error, obj_to_string(type_obj)->s); obj_string_mut_append(eval_error, "' type: "); obj_string_mut_append(eval_error, obj_to_string(meta_type_tag)->s); return; } hack:; #endif values[i] = &args[i]->void_ptr; } else if(args[i]->tag == 'A') { // TODO: Do some type checking here!!! Array *a = obj_array_to_carp_array(process, args[i]); if(eval_error) { return; } assert(a); values[i] = &a; } else if(args[i]->tag == 'F') { values[i] = &args[i]->funptr; } else if(args[i]->tag == 'L') { if(ALLOW_SENDING_LAMBDA_TO_FFI) { //printf("Will call unbaked lambda from ffi function. Lambda should have types: %s\n", obj_to_string(type_obj)->s); ffi_type *closure_args[1]; ffi_closure *closure; void (*closure_fun_ptr)(); closure = ffi_closure_alloc(sizeof(ffi_closure), (void**)&closure_fun_ptr); if (closure) { /* Initialize the argument info vectors */ closure_args[0] = &ffi_type_pointer; /* ffi_cif cif_static; */ /* ffi_cif *cif = &cif_static; */ /* ffi_prep_cif(cif, FFI_DEFAULT_ABI, 0, &ffi_type_void, closure_args); */ //printf("Type obj: %s\n", obj_to_string(type_obj)->s); Obj *lambda_arg_types = type_obj->cdr->car; Obj *lambda_return_type = type_obj->cdr->cdr->car; int lambda_arg_count = 0; Obj *p = lambda_arg_types; while(p && p->car) { p = p->cdr; lambda_arg_count++; } ffi_cif *cif = create_cif(process, lambda_arg_types, lambda_arg_count, lambda_return_type, "TODO:proper-name"); Obj *lambda_arg = args[i]; LambdaAndItsType *lambda_and_its_type = malloc(sizeof(LambdaAndItsType)); // TODO: free! lambda_and_its_type->lambda = lambda_arg; // the uncompiled lambda that was passed to the ffi function lambda_and_its_type->signature = type_obj; lambda_and_its_type->process = process; typedef void (*LambdaCallback)(ffi_cif *, void *, void **, void *); if (ffi_prep_closure_loc(closure, cif, (LambdaCallback)call_lambda_from_ffi, lambda_and_its_type, closure_fun_ptr) == FFI_OK) { //printf("Closure preparation done.\n"); values[i] = &closure_fun_ptr; } else { set_error("Closure prep failed. ", nil); } } else { set_error("Failed to allocate closure. ", nil); } } else { free(values); set_error("Can't send argument of lambda type (tag 'L') to ffi function, you need to compile it to a C function using (bake ...) first:\n", args[i]); } } else { free(values); printf("INVALID ARG TYPE: %c\n", args[i]->tag); printf("ARG: %s\n", obj_to_string(process, args[i])->s); set_error("Can't send argument of invalid type to foreign function taking parameter of type ", p->car); } } p = p->cdr; } else { free(values); set_error("Too many arguments to ", function); } } if(p && p->car) { free(values); set_error("Too few arguments to ", function); } // Handle refs: Obj *return_type = function->return_type; if(return_type->tag == 'C' && return_type->car && return_type->cdr && return_type->cdr->car && obj_eq(process, return_type->car, type_ref)) { return_type = return_type->cdr->car; // the second element of the list } void *result; ffi_call(function->cif, function->funptr, &result, values); Obj *obj_result = primitive_to_obj(process, result, return_type); free(values); if(!obj_result) { printf("obj_result == NULL, return_type = %s\n", obj_to_string(process, return_type)->s); return; // something went wrong } stack_push(process, obj_result); }
void call_lambda_from_ffi(ffi_cif *cif, void *ret, void* args[], LambdaAndItsType *lambda_and_its_type) { //printf("Calling lambda %s from ffi function!\n", obj_to_string(lambda_and_its_type->lambda)->s); int arg_count = cif->nargs; //printf("arg count: %d\n", arg_count); Obj **obj_args = malloc(sizeof(Obj*) * arg_count); //Obj *obj_args[arg_count]; Obj *lambda_type_signature = lambda_and_its_type->signature; // TODO: shadow stack?! Obj *lambda_return_type = lambda_type_signature->cdr->cdr->car; Obj *lambda_arg_type_list_p = lambda_type_signature->cdr->car; //printf("Lambda signature: %s\n", obj_to_string(lambda_type_signature)->s); Process *process = lambda_and_its_type->process; for(int i = 0; i < arg_count; i++) { Obj *lambda_arg_type_p = lambda_arg_type_list_p->car; if(!lambda_arg_type_p) { printf("Too many arguments (%d) sent to lambda with signature: %s\n", arg_count, obj_to_string(process, lambda_type_signature)->s); eval_error = obj_new_string("Too many args."); return; } // Unwrap ref args if(lambda_arg_type_p->tag == 'C' && lambda_arg_type_p->car && lambda_arg_type_p->cdr && lambda_arg_type_p->cdr->car && obj_eq(process, lambda_arg_type_p->car, obj_new_keyword("ref"))) { lambda_arg_type_p = lambda_arg_type_p->cdr->car; // the second element of the list } //printf("Lambda arg p: %s\n", obj_to_string(lambda_arg_type_p)->s); if(cif->arg_types[i] == &ffi_type_sint) { int *x = args[i]; obj_args[i] = obj_new_int(*x); } else if(cif->arg_types[i] == &ffi_type_float) { float *x = args[i]; obj_args[i] = obj_new_float(*x); } else if(cif->arg_types[i] == &ffi_type_double) { double *x = args[i]; obj_args[i] = obj_new_double(*x); } else if(cif->arg_types[i] == &ffi_type_schar) { char *x = args[i]; obj_args[i] = obj_new_char(*x); } else { if(obj_eq(process, lambda_arg_type_p, type_string)) { char **x = args[i]; assert(*x); char *new_s = strdup(*x); //printf("new_s: %s\n", new_s); obj_args[i] = obj_new_string(new_s); } else { //printf("Lambda called from ffi with arg %d of type %s\n", i, obj_to_string(lambda_arg_type_p)->s); /* printf("Can't handle arg type %p when calling ffi function.\n", cif->arg_types[i]); */ /* set_error("FFI function failed to call lambda: ", lambda_and_its_type->lambda); */ /* return; */ void **ptr = args[i]; obj_args[i] = obj_new_ptr(*ptr); } } //printf("arg %d: %s\n", i, obj_to_string(obj_args[i])->s); lambda_arg_type_list_p = lambda_arg_type_list_p->cdr; //shadow_stack_push(obj_args[i]); } apply(process, lambda_and_its_type->lambda, obj_args, cif->nargs); Obj *result = stack_pop(process); free(obj_args); // unwrap ref if(lambda_return_type->tag == 'C' && lambda_return_type->car && lambda_return_type->cdr && lambda_return_type->cdr->car && obj_eq(process, lambda_return_type->car, obj_new_keyword("ref"))) { lambda_return_type = lambda_return_type->cdr->car; // the second element of the list } // TODO: extract this and refactor to common helper function if(obj_eq(process, lambda_return_type, type_int)) { assert_or_set_error(result->tag == 'I', "Invalid type of return value: ", result); int *integer = ret; *integer = result->i; } else if(obj_eq(process, lambda_return_type, type_bool)) { assert_or_set_error(result->tag == 'Y', "Invalid type of return value ", result); bool b = is_true(result); bool *boolean = ret; *boolean = b; } else if(obj_eq(process, lambda_return_type, type_char)) { assert_or_set_error(result->tag == 'T', "Invalid type of return value ", result); char c = result->character; char *character = ret; *character = c; } else if(obj_eq(process, lambda_return_type, type_float)) { assert_or_set_error(result->tag == 'V', "Invalid type of return value ", result); float *x = ret; *x = result->f32; } else if(obj_eq(process, lambda_return_type, type_double)) { assert_or_set_error(result->tag == 'W', "Invalid type of return value ", result); double *x = ret; *x = result->f64; } else if(obj_eq(process, lambda_return_type, type_string)) { assert_or_set_error(result->tag == 'S', "Invalid type of return value ", result); char **s = ret; *s = result->s; } else if(obj_eq(process, lambda_return_type, type_void)) { } else { //set_error("Calling lambda from FFI can't handle return type ", lambda_return_type); assert_or_set_error(result->tag == 'Q', "Invalid type of return value ", result); void **p = ret; *p = result->void_ptr; } /* for(int i = 0; i < arg_count; i++) { */ /* shadow_stack_pop(process); */ /* } */ }
Process *process_new() { Process *process = malloc(sizeof(Process)); process->dead = false; process->final_result = NULL; #if BYTECODE_EVAL process->frame = 0; #else process->frame = -1; #endif process->bytecodeObj = NULL; pop_stacks_to_zero(process); process->global_env = obj_new_environment(NULL); nil = obj_new_cons(NULL, NULL); define("nil", nil); lisp_false = obj_new_bool(false); define("false", lisp_false); lisp_true = obj_new_bool(true); define("true", lisp_true); lisp_quote = obj_new_symbol("quote"); define("quote", lisp_quote); ampersand = obj_new_symbol("&"); define("&", ampersand); dotdotdot = obj_new_symbol("dotdotdot"); define("dotdotdot", dotdotdot); hash = obj_new_keyword("hash"); define("hash", hash); lisp_NULL = obj_new_ptr(NULL); define("NULL", lisp_NULL); type_ref = obj_new_keyword("ref"); define("type_ref", type_ref); type_int = obj_new_keyword("int"); define("type-int", type_int); // without this it will get GC'd! type_bool = obj_new_keyword("bool"); define("type-bool", type_bool); type_float = obj_new_keyword("float"); define("type-float", type_float); type_double = obj_new_keyword("double"); define("type-double", type_double); type_string = obj_new_keyword("string"); define("type-string", type_string); type_symbol = obj_new_keyword("symbol"); define("type-symbol", type_symbol); type_keyword = obj_new_keyword("keyword"); define("type-keyword", type_keyword); type_foreign = obj_new_keyword("foreign"); define("type-foreign", type_foreign); type_primop = obj_new_keyword("primop"); define("type-primop", type_primop); type_env = obj_new_keyword("env"); define("type-env", type_env); type_macro = obj_new_keyword("macro"); define("type-macro", type_macro); type_lambda = obj_new_keyword("lambda"); define("type-lambda", type_lambda); type_list = obj_new_keyword("list"); define("type-list", type_list); type_void = obj_new_keyword("void"); define("type-void", type_void); type_ptr = obj_new_keyword("ptr"); define("type-ptr", type_ptr); type_char = obj_new_keyword("char"); define("type-char", type_char); type_array = obj_new_keyword("array"); define("type-array", type_array); type_ptr_to_global = obj_new_keyword("ptr-to-global"); define("type-ptr-to-global", type_ptr_to_global); prompt = define("prompt", obj_new_string(PROMPT)); prompt_unfinished_form = define("prompt-unfinished-form", obj_new_string(PROMPT_UNFINISHED_FORM)); register_primop(process, "open", p_open_file); register_primop(process, "save", p_save_file); register_primop(process, "+", p_add); register_primop(process, "-", p_sub); register_primop(process, "*", p_mul); register_primop(process, "/", p_div); //register_primop(process, "mod", p_mod); register_primop(process, "=", p_eq); register_primop(process, "list", p_list); register_primop(process, "array", p_array); register_primop(process, "dictionary", p_dictionary); register_primop(process, "str", p_str); register_primop(process, "str-append!", p_str_append_bang); register_primop(process, "str-replace", p_str_replace); register_primop(process, "join", p_join); register_primop(process, "register", p_register); register_primop(process, "register-variable", p_register_variable); register_primop(process, "register-builtin", p_register_builtin); register_primop(process, "print", p_print); register_primop(process, "println", p_println); register_primop(process, "prn", p_prn); register_primop(process, "def?", p_def_QMARK); //register_primop(process, "system", p_system); register_primop(process, "get", p_get); register_primop(process, "get-maybe", p_get_maybe); register_primop(process, "dict-set!", p_dict_set_bang); register_primop(process, "dict-remove!", p_dict_remove_bang); register_primop(process, "first", p_first); register_primop(process, "rest", p_rest); register_primop(process, "cons", p_cons); register_primop(process, "cons-last", p_cons_last); register_primop(process, "concat", p_concat); register_primop(process, "nth", p_nth); register_primop(process, "count", p_count); register_primop(process, "map", p_map); register_primop(process, "map-copy", p_map); // only matters when compiling to C register_primop(process, "map2", p_map2); register_primop(process, "filter", p_filter); register_primop(process, "reduce", p_reduce); register_primop(process, "apply", p_apply); register_primop(process, "type", p_type); register_primop(process, "<", p_lt); register_primop(process, "env", p_env); register_primop(process, "load-lisp", p_load_lisp); register_primop(process, "load-dylib", p_load_dylib); register_primop(process, "unload-dylib", p_unload_dylib); register_primop(process, "read", p_read); register_primop(process, "read-many", p_read_many); register_primop(process, "code", p_code); register_primop(process, "copy", p_copy); register_primop(process, "now", p_now); register_primop(process, "name", p_name); register_primop(process, "symbol", p_symbol); register_primop(process, "keyword", p_keyword); register_primop(process, "error", p_error); register_primop(process, "keys", p_keys); register_primop(process, "values", p_values); register_primop(process, "signature", p_signature); register_primop(process, "eval", p_eval); register_primop(process, "meta-set!", p_meta_set_BANG); register_primop(process, "meta-get", p_meta_get); register_primop(process, "meta-get-all", p_meta_get_all); register_primop(process, "array-to-list", p_array_to_list); register_primop(process, "array-of-size", p_array_of_size); register_primop(process, "array-set!", p_array_set_BANG); register_primop(process, "array-set", p_array_set); register_primop(process, "gc", p_gc); register_primop(process, "hash", p_hash); register_primop(process, "delete", p_delete); register_primop(process, "stop", p_stop); register_primop(process, "parallell", p_parallell); register_primop(process, "bytecode", p_bytecode); register_primop(process, "eval-bytecode", p_bytecode_eval); register_primop(process, "lookup-in-substs-fast", p_lookup_in_substs_fast); register_primop(process, "replace-subst-from-right-fast", p_replace_subst_from_right_fast); register_primop(process, "types-exactly-eq?", p_types_exactly_eq); register_primop(process, "extend-substitutions-fast", p_extend_substitutions_fast); register_primop(process, "sort-by-fast", p_sort_by); Obj *abs_args = obj_list(type_int); register_ffi_internal(process, "abs", (VoidFn)abs, abs_args, type_int, true); Obj *exit_args = obj_list(type_int); register_ffi_internal(process, "exit", (VoidFn)exit, exit_args, type_void, true); Obj *getenv_args = obj_list(type_string); register_ffi_internal(process, "getenv", (VoidFn)getenv, getenv_args, type_string, true); //printf("Global env: %s\n", obj_to_string(env)->s); return process; }