object_t primitive_isnull(object_t argl) {
if(isnull(car(argl))) {
return obj_new_symbol("#t");
} else {
return obj_new_symbol("#f");
}
}
object_t primitive_file_append(object_t argl) {
char *string = obj_get_string(car(argl));
char *filename = obj_get_string(car(cdr(argl)));
if(file_append(string, filename))
return obj_new_symbol("#t");
else
return obj_new_symbol("#f");
}
object_t primitive_read(object_t argl) {
object_t r = parse_sexp(read_sexp(stdin));
if(r == NULL)
return obj_new_symbol("_empty_");
else
return r;
}
object_t cmp_primitive(object_t argl, int (*f) (int, int)) {
int arg1 = obj_get_number(car(argl));
argl = cdr(argl);
int arg2;
object_t ret;
while(!isnull(argl)) {
arg2 = obj_get_number(car(argl));
if(!f(arg1, arg2)) {
ret = obj_new_symbol("#f");
return ret;
}
arg1 = arg2;
argl = cdr(argl);
}
ret = obj_new_symbol("#t");
return ret;
}
object_t parse_sexp2(char **in, object_t current) {
char *buf;
enum kind k = next_token(in, &buf);
object_t rest, s;
switch(k) {
case End:
return current;
case Left:
rest = parse_sexp2(in, NIL);
if(current == NULL)
return rest;
else if(current == NIL)
current = cons(rest, NIL);
else
storage_append(rest, current);
return parse_sexp2(in, current);
case Right:
return current;
case Period:
rest = parse_sexp2(in, NULL);
set_cdr(storage_last(current), rest);
return parse_sexp2(in, current);
case Single: /* following are reader-macros */
return wrap(in, current, "quote");
case Back:
return wrap(in, current, "quasiquote");
case Comma:
return wrap(in, current, "unquote");
case Symbol:
case String:
if(k == Symbol) {
if(all_digits(buf))
s = obj_new_number(atoi(buf));
else
s = obj_new_symbol(buf);
}
else if(k == String)
s = obj_new_string(buf);
if(current == NULL)
return s;
else if(current == NIL)
return parse_sexp2(in, cons(s, NIL));
else {
storage_append(s, current);
return parse_sexp2(in, current);
}
}
return NULL;
}
object_t primitive_eq(object_t argl) {
object_t a1 = car(argl);
object_t a2 = car(cdr(argl));
int result;
if(issymbol(a1) && issymbol(a2))
result = obj_symbol_cmp(a1, a2);
else if(isnum(a1) && isnum(a2))
result = (obj_get_number(a1) == obj_get_number(a2));
else
result = 0;
if(result)
return obj_new_symbol("#t");
else
return obj_new_symbol("#f");
}
object_t read_file(char *filename) {
FILE *f = fopen(filename, "r");
char *input;
object_t seq = cons(obj_new_symbol("begin"), NIL);
while((input = read_sexp(f)) != NULL) {
object_t exp = parse_sexp(input);
storage_append(exp, seq);
}
return seq;
}
object_t wrap(char **in, object_t current, char *type) {
object_t rest = parse_sexp2(in, NULL);
object_t ret = cons(obj_new_symbol(type), cons(rest, NIL));
if(current == NULL) {
return ret;
} else if(current == NIL) {
current = cons(ret, NIL);
} else {
storage_append(ret, current);
}
return parse_sexp2(in, current);
}
object_t primitive_set_cdr(object_t argl) {
set_cdr(car(argl), car(cdr(argl)));
return obj_new_symbol("ok");
}
object_t primitive_numberp(object_t argl) {
if(isnum(car(argl)))
return obj_new_symbol("#t");
else
return obj_new_symbol("#f");
}
object_t init_global() {
object_t env = NIL;
object_t primitives[] = {
obj_new_symbol("+"), obj_new_primitive(&primitive_add),
obj_new_symbol("*"), obj_new_primitive(&primitive_multiply),
obj_new_symbol("-"), obj_new_primitive(&primitive_subtract),
obj_new_symbol("/"), obj_new_primitive(&primitive_divide),
obj_new_symbol("<"), obj_new_primitive(&primitive_lessthan),
obj_new_symbol(">"), obj_new_primitive(&primitive_greaterthan),
obj_new_symbol("="), obj_new_primitive(&primitive_equals),
obj_new_symbol("cons"), obj_new_primitive(&primitive_cons),
obj_new_symbol("car"), obj_new_primitive(&primitive_car),
obj_new_symbol("cdr"), obj_new_primitive(&primitive_cdr),
obj_new_symbol("null?"), obj_new_primitive(&primitive_isnull),
obj_new_symbol("eq?"), obj_new_primitive(&primitive_eq),
obj_new_symbol("set-cdr!"), obj_new_primitive(&primitive_set_cdr),
obj_new_symbol("set-car!"), obj_new_primitive(&primitive_set_car),
obj_new_symbol("symbol?"), obj_new_primitive(&primitive_symbolp),
obj_new_symbol("cons?"), obj_new_primitive(&primitive_consp),
obj_new_symbol("load"), obj_new_primitive(&primitive_load),
obj_new_symbol("print"), obj_new_primitive(&primitive_print),
obj_new_symbol("eval"), obj_new_primitive(&primitive_eval),
obj_new_symbol("apply"), obj_new_primitive(&primitive_apply),
obj_new_symbol("read"), obj_new_primitive(&primitive_read),
obj_new_symbol("read-file"), obj_new_primitive(&primitive_read_file),
obj_new_symbol("quit"), obj_new_primitive(&primitive_quit),
obj_new_symbol("error"), obj_new_primitive(&primitive_error),
obj_new_symbol("string?"), obj_new_primitive(&primitive_stringp),
obj_new_symbol("number?"), obj_new_primitive(&primitive_numberp),
obj_new_symbol("file-append"), obj_new_primitive(&primitive_file_append),
obj_new_symbol("symbol->string"), obj_new_primitive(&primitive_symbol2string),
obj_new_symbol("string->symbol"), obj_new_primitive(&primitive_string2symbol),
obj_new_symbol("string-append"), obj_new_primitive(&primitive_string_append),
obj_new_symbol("number->string"), obj_new_primitive(&primitive_number2string),
obj_new_symbol("read-char"), obj_new_primitive(&primitive_read_char),
obj_new_symbol("string-length"), obj_new_primitive(&primitive_string_length),
obj_new_symbol("string="), obj_new_primitive(&primitive_string_equals),
obj_new_symbol("string-ref"), obj_new_primitive(&primitive_string_ref)
};
int i;
for(i = 0; i < 70; i+=2)
env = define_variable(primitives[i], primitives[i+1], env);
return env;
}
object_t primitive_load(object_t argl) {
load_file(obj_get_string(car(argl)), &global_env);
return obj_new_symbol("loaded.");
}
object_t make_compiled_procedure(object_t entry, object_t environment) {
return cons(obj_new_symbol("compiled-procedure"),
cons(entry,
cons(environment, NIL)));
}
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 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);
}
}
object_t primitive_string_equals(object_t argl) {
int c = strcmp(obj_get_string(car(argl)), obj_get_string(car(cdr(argl))));
return c==0 ? obj_new_symbol("#t") : obj_new_symbol("#f");
}
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;
}
object_t primitive_string2symbol(object_t argl) {
return obj_new_symbol(obj_get_string(car(argl)));
}
object_t primitive_stringp(object_t argl) {
if(isstring(car(argl)))
return obj_new_symbol("#t");
else
return obj_new_symbol("#f");
}
object_t primitive_consp(object_t argl) {
if(iscons(car(argl)))
return obj_new_symbol("#t");
else
return obj_new_symbol("#f");
}
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;
}