static Env* make_global_env(US* us)
{
struct {
const char* name;
NativeFunc* func;
} data[] = {
{ "+" , func_add },
{ "-" , func_sub },
{ "*" , func_mul },
{ "/" , func_div },
{ "=" , func_eq },
{ ">" , func_gt },
{ "<" , func_lt },
{ "cons" , func_cons },
{ "car" , func_car },
{ "cdr" , func_cdr },
{ "begin" , func_begin },
};
Env* env = arena_get_env(us->arena, 0);
int n = sizeof(data) / sizeof(data[0]);
LOG(INFO, ("US: registering all %d native handlers, us %p, arena %p", n, us, us->arena));
for (int j = 0; j < n; ++j) {
const char* name = data[j].name;
Symbol* sym = env_lookup(env, name, 1);
sym->value = cell_create_native(us, name, data[j].func);
LOG(INFO, ("US: registered native handler for [%s]", name));
}
LOG(INFO, ("US: registered all %d native handlers, us %p, arena %p", n, us, us->arena));
arena_dump(us->arena, stderr);
return env;
}
void connect_interface(location l, cgraph cg, cgraph userg,
struct endp from, struct endp to,
bool reverse)
{
env_scanner scanfns;
const char *fnname;
void *fnentry;
if (to.interface->required ^ reverse)
connect_userg(l, userg, to, from);
else
connect_userg(l, userg, from, to);
assert(!from.function && !to.function
/*&& from.interface->itype == to.interface->itype*/);
/* All functions */
interface_scan(to.interface, &scanfns);
while (env_next(&scanfns, &fnname, &fnentry))
{
data_declaration fndecl = fnentry;
assert(fndecl->kind == decl_function);
to.function = fndecl;
from.function = env_lookup(from.interface->functions->id_env, fndecl->name, TRUE);
if (fndecl->defined ^ reverse)
connect_cg(cg, from, to);
else
connect_cg(cg, to, from);
}
}
int
main(int argc, char* argv[])
{
init_symbol_table();
init_builtin_types();
init_global_env();
init_singleton_objects();
init_primitive_procs();
struct vm_context *global_ctx = make_vm_context(NULL, NULL,
global_env);
INC_REF(&global_ctx->obj);
struct vm_context **pctx = &global_ctx;
struct object *value;
value = load("prelude.scm", pctx);
YIELD_OBJ(value);
init_compiler();
value = load("stage2.scm", pctx);
YIELD_OBJ(value);
struct vm_context *repl_ctx;
repl_ctx = make_vm_context(NULL, make_stack(1024),
make_environment(global_env));
INC_REF(&repl_ctx->obj);
pctx = &repl_ctx;
struct object *ret = env_lookup(global_env, "initial-repl");
assert(ret->type->code == PROCEDURE_TYPE);
struct procedure *repl = container_of(ret, struct procedure, obj);
apply_and_run(repl, NIL, pctx);
return 0;
}
void load_scheduler(void)
{
scheduler = load(l_component, toplevel_location, scheduler_name, FALSE);
if (scheduler_name)
{
data_declaration intf = env_lookup(scheduler->env->id_env,
scheduler_interface_name, TRUE);
/* Check interface for validity. It must be the provided, have a
single parameter and be the right interface type.
Also, no generic interfaces please. */
if (intf && intf->kind == decl_interface_ref && !intf->required &&
intf->gparms && !intf->itype->abstract &&
!strcmp(intf->itype->name, scheduler_interfacedef_name))
{
typelist_scanner dummy;
typelist_scan(intf->gparms, &dummy);
if (typelist_next(&dummy) && !typelist_next(&dummy))
scheduler_interface = intf;
}
if (!scheduler_interface)
error_with_location(toplevel_location,
"Scheduler `%s' has no scheduling interface named `%s'",
scheduler_name, scheduler_interface_name);
}
}
extern cv_t c_eval(obj_t cont, obj_t values)
{
assert(is_cont4(cont));
obj_t expr = cont4_arg(cont);
EVAL_LOG("expr=%O", expr);
COULD_RETRY();
if (is_self_evaluating(expr))
return cv(cont_cont(cont), CONS(expr, values));
else if (is_symbol(expr)) {
obj_t env = cont_env(cont);
obj_t val = env_lookup(env, expr);
return cv(cont_cont(cont), CONS(val, values));
#if !OLD_ENV
} else if (is_env_ref(expr)) {
return cv(cont_cont(cont),
CONS(env_ref_lookup(cont_env(cont), expr), values));
#endif
} else if (is_application(expr)) {
obj_t operator = application_operator(expr);
obj_t env = cont_env(cont);
obj_t second = make_cont4(c_eval_operator,
cont_cont(cont),
env,
expr);
obj_t first = make_cont4(c_eval, second, env, operator);
return cv(first, values);
}
SYNTAX_ERROR(expr, expr, "must be expression");
}
void register_procs(void)
{
root_env = make_env(NIL);
while (proc_descs) {
proc_descriptor_t *desc = proc_descs;
obj_t *library = find_library_str(desc->pd_libdesc->ld_namespec);
(*desc->pd_binder)(desc->pd_proc, library, desc->pd_name);
proc_descs = desc->pd_next;
}
AUTO_ROOT(value, NIL);
AUTO_ROOT(new_env, NIL);
AUTO_ROOT(old_env, NIL);
while (alias_descs) {
alias_descriptor_t *desc = alias_descs;
const wchar_t *old_namespec = desc->ad_old_libdesc->ld_namespec;
obj_t *old_library = find_library_str(old_namespec);
old_env = library_env(old_library);
obj_t *old_sym = make_symbol_from_C_str(desc->ad_old_name);
obj_t *binding = env_lookup(old_env, old_sym);
value = binding_value(binding);
const wchar_t *new_namespec = desc->ad_new_libdesc->ld_namespec;
obj_t *new_library = find_library_str(new_namespec);
new_env = library_env(new_library);
obj_t *new_symbol = make_symbol_from_C_str(desc->ad_new_name);
env_bind(new_env, new_symbol, BT_LEXICAL, M_IMMUTABLE, value);
alias_descs = desc->ad_next;
}
POP_FUNCTION_ROOTS();
}
// This is where most of the strict/lazy distinction is.
static value_t *e_fncall(env_t *env, expr_t *expr)
{
eli_closure_t c;
binding_t *fn;
// Call-by-value (strict function calls): evaluate each argument to
// a value in the given environment.
c.env = env;
c.list = list_empty();
list_iterate(fncall_args(expr), e_expr_list_i, &c);
list_reverse(c.list);
switch (fncall_fn(expr)->type) {
case p_var:
// The function is literally the name of a function, and is
// defined in the global environment.
fn = (binding_t *)env_lookup(global_env, var_name(fncall_fn(expr)));
assert(fn != NULL);
// We must have exactly as many arguments as parameters.
assert(list_length(c.list) == list_length(fn->params));
// Bind the function's parameters to the given arguments in a new
// scope derived from the global scope.
env = global_env;
env_new_scope(&env);
list_zip_with(fn->params,
c.list,
e_bind_params_i, env);
// Evaluate the function's body in the new environment.
return e_expr(env, fn->body);
case p_datacons:
{
value_t *result;
result = alloc_value(v_datacons);
datacons_tag(result) = datacons_tag(fncall_fn(expr));
datacons_params(result) = c.list;
// FIXME we'd like to assert that we got the right number of
// arguments, but we don't know how many the data constructor
// wanted.
return result;
}
default:
fprintf(stdout, "e_fncall: expression:\n");
pp_expr(stdout, fncall_fn(expr), 2);
fprintf(stdout, "\non line %d is not a function-variable or a data constructor.\n", fn->line_num);
error("");
return NULL;
}
}
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");
}
int env_addvar( env_h env, env_h from_env, char *var_name )
{
char *var_string = env_lookup( from_env, var_name ) ;
if ( var_string == NULL )
{
env_errno = ENV_EBADVAR ;
return( ENV_ERR ) ;
}
return( addstring( env, var_string, strlen( var_name ) ) ) ;
}
void declare_interface_ref(interface_ref iref, declaration gparms,
environment env, attribute attribs)
{
const char *iname = (iref->word2 ? iref->word2 : iref->word1)->cstring.data;
nesc_declaration idecl =
require(l_interface, iref->location, iref->word1->cstring.data);
struct data_declaration tempdecl;
data_declaration old_decl, ddecl;
init_data_declaration(&tempdecl, CAST(declaration, iref), iname, void_type);
tempdecl.kind = decl_interface_ref;
tempdecl.type = NULL;
tempdecl.itype = idecl;
tempdecl.container = current.container;
tempdecl.required = current.spec_section == spec_uses;
tempdecl.gparms = gparms ? make_gparm_typelist(gparms) : NULL;
handle_decl_attributes(attribs, &tempdecl);
old_decl = env_lookup(env->id_env, iname, TRUE);
if (old_decl)
error("redefinition of `%s'", iname);
ddecl = declare(env, &tempdecl, FALSE);
iref->attributes = attribs;
iref->ddecl = ddecl;
if (idecl->abstract)
{
generic_used = TRUE;
check_abstract_arguments("interface", ddecl,
idecl->parameters, iref->args);
ddecl->itype = interface_copy(parse_region, iref,
current.container->abstract);
ddecl->functions = ddecl->itype->env;
}
else
{
copy_interface_functions(parse_region, current.container, ddecl,
ddecl->itype->env);
if (iref->args)
error("unexpected type arguments");
}
/* We don't make the interface type generic. Instead, we push the generic
type into each function in copy_interface_functions. This is because
the syntax for invoking or defining a function on a generic interface
is interfacename.functionname[generic args](...) */
if (gparms)
set_interface_functions_gparms(ddecl->functions, ddecl->gparms);
ddecl->type = make_interface_type(ddecl);
}
void * env_lookup(Env env, char * key) {
int i;
if (env == NULL) {
printf("Did not find key '%s'\n", key);
return NULL;
}
for (i = 0; i < env->size; i++) {
if (strcmp(env->pairs[i].key, key) == 0) {
return env->pairs[i].ref_countable;
}
}
return env_lookup(env->parent, key);
}
GCPtr env_lookup(const Environment *e, int id) {
if(e->env_map) {
env_map_find_return ret = env_map_find(e->env_map, id);
if(ret.found)
return ret.val;
}
if(e->parent)
return env_lookup(e->parent, id);
else {
sprintf(ex_buf, "unbouded_variable:%s", extern_symbol(id));
throw_jump();
}
}
static pobject set(pobject env, pobject params)
{
pobject symbol = cons_car(params);
if (is_symbol(symbol)) {
pobject value = eval(env, cons_nth(params, 2));
pobject cons = env_lookup(env, symbol);
if (is_cons(cons)) {
cons_car_set(cons, value);
return value;
}
}
return NIL;
}
Obj *env_lookup(Obj *env, Obj *symbol) {
Obj *p = env->bindings;
while(p && p->car) {
Obj *pair = p->car;
if(obj_eq(pair->car, symbol)) {
return pair->cdr;
}
else {
p = p->cdr;
}
}
if(env->parent) {
return env_lookup(env->parent, symbol);
}
else {
return NULL;
}
}
Obj *env_lookup(Process *process, Obj *env, Obj *symbol) {
assert(env->tag == 'E');
Obj *p = env->bindings;
while(p && p->car) {
Obj *pair = p->car;
if(obj_eq(process, pair->car, symbol)) {
return pair->cdr;
}
else {
p = p->cdr;
}
}
if(env->parent) {
return env_lookup(process, env->parent, symbol);
}
else {
return NULL;
}
}
static void generate_execute(component acall, int count, fncode fn)
{
/* Optimise main case: calling a given global function */
if (acall->vclass == c_recall)
{
ulong offset;
bool is_static;
variable_class vclass = env_lookup(acall->u.recall, &offset,
true, false, &is_static);
if (vclass == global_var)
{
assert(!is_static);
mexecute(offset, acall->u.recall, count, fn);
return;
}
}
generate_component(acall, fn);
ins1(op_execute, count, fn);
}
static void generate_decls(vlist decls, fncode fn)
{
/* Generate code for initialisers */
for (; decls; decls = decls->next)
if (decls->init)
{
u16 offset;
mtype t;
variable_class vclass = env_lookup(decls->l, decls->var, &offset, &t, FALSE);
generate_component(decls->init, NULL, FALSE, fn);
if (t != stype_any)
ins0(OPmscheck4 + t, fn);
if (vclass == global_var)
massign(decls->l, offset, decls->var, fn);
else
ins1(OPmwritel, offset, fn);
ins0(OPmpop, fn);
}
}
static void generate_block(block b, fncode fn)
{
clist cc = b->sequence;
env_block_push(b->locals, b->statics);
if (b->statics)
for (vlist vl = b->locals; vl; vl = vl->next)
{
ulong offset;
bool is_static;
variable_class vclass = env_lookup(vl->var, &offset,
false, true, &is_static);
assert(is_static && vclass == local_var);
ins_constant(alloc_string(vl->var), fn);
mexecute(g_get_static, NULL, 1, fn);
ins1(op_assign + vclass, offset, fn);
}
/* Generate code for sequence */
for (; cc; cc = cc->next)
{
generate_component(cc->c, fn);
if (cc->next) ins0(op_discard, fn);
}
for (vlist vl = b->locals; vl; vl = vl->next)
if (!vl->was_written)
if (!vl->was_read)
warning_line(b->filename, b->nicename, vl->lineno,
"local variable %s is unused", vl->var);
else
warning_line(b->filename, b->nicename, vl->lineno,
"local variable %s is never written", vl->var);
else if (!vl->was_read)
warning_line(b->filename, b->nicename, vl->lineno,
"local variable %s is never read", vl->var);
env_block_pop();
}
void generate_execute(component acall, int count, fncode fn)
{
if (count >= 16)
log_error(acall->l, "no more than 15 arguments allowed");
/* Optimise main case: calling a given global function. Also
support implicit function declaration. */
if (acall->vclass == c_recall)
{
u16 offset;
mtype t;
variable_class vclass = env_lookup(acall->l, acall->u.recall, &offset, &t, TRUE);
if (vclass == global_var)
{
mexecute(acall->l, offset, acall->u.recall, count, fn);
return;
}
}
generate_component(acall, NULL, FALSE, fn);
ins0(OPmexec4 + (count & 0xf), fn);
}
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);
}
}
static iattr internal_lookup(nesc_attribute attr)
{
return env_lookup(internal_attributes, attr->word1->cstring.data, TRUE);
}
struct value env_lookup(struct env e, char *name)
{
int i;
struct value err = {.type = VERR, .v = 3};
for(i = e.top - 1; i >= 0; i--)
{
if(strcmp(name, e.tab[i].name) == 0)
return e.tab[i].v;
}
return err;
}
struct value value_int(int v)
{
struct value x = {.type = VINT, .v = v};
return x;
}
struct value value_bool(bool b)
{
struct value x = {.type = VBOOL, .b = b};
return x;
}
struct value value_err(struct value v1, struct value v2, int e)
{
struct value x = {.type = VERR, .v = e};
if(v1.type == VERR)
return v1;
if(v2.type == VERR)
return v2;
return x;
}
struct sexp *atom_i(int v)
{
struct sexp *s = malloc(sizeof(struct sexp));
s->type = ATOM_I;
s->atom_i = v;
return s;
}
struct sexp *atom_b(bool v)
{
struct sexp *s = malloc(sizeof(struct sexp));
s->type = ATOM_B;
s->atom_b = v;
return s;
}
struct sexp *atom_n(char *n)
{
struct sexp *s = malloc(sizeof(struct sexp));
s->type = ATOM_N;
strcpy(s->atom_n, n);
return s;
}
struct sexp *sexp(enum op op, struct sexp *s1, struct sexp *s2, struct sexp *s3)
{
struct sexp *s = malloc(sizeof(struct sexp));
s->type = SEXP;
s->sexp.op = op;
s->sexp.s1 = s1;
s->sexp.s2 = s2;
s->sexp.s3 = s3;
return s;
}
struct value eval(struct env env, struct sexp *s)
{
struct value v1, v2, v3;
switch(s->type)
{
case ATOM_B:
return value_bool(s->atom_b);
case ATOM_I:
return value_int(s->atom_i);
case ATOM_N:
return env_lookup(env, s->atom_n);
default:
switch(s->sexp.op) {
case ADD:
v1 = eval(env, s->sexp.s1);
v2 = eval(env, s->sexp.s2);
if(v1.type == VINT &&
v2.type == VINT)
return value_int(v1.v + v2.v);
else
return value_err(v1, v2, 1);
case SUB:
v1 = eval(env, s->sexp.s1);
v2 = eval(env, s->sexp.s2);
if(v1.type == VINT &&
v2.type == VINT)
return value_int(v1.v - v2.v);
else
return value_err(v1, v2, 1);
case MUL:
v1 = eval(env, s->sexp.s1);
v2 = eval(env, s->sexp.s2);
if(v1.type == VINT &&
v2.type == VINT)
return value_int(v1.v * v2.v);
else
return value_err(v1, v2, 1);
case DIV:
v1 = eval(env, s->sexp.s1);
v2 = eval(env, s->sexp.s2);
if(v1.type == VINT &&
v2.type == VINT)
if(v2.v == 0)
return value_err(v1, v1, 2);
else
return value_int(v1.v / v2.v);
else
return value_err(v1, v2, 1);
case LT:
v1 = eval(env, s->sexp.s1);
v2 = eval(env, s->sexp.s2);
if(v1.type == VINT &&
v2.type == VINT)
return value_bool(v1.v < v2.v);
else
return value_err(v1, v2, 1);
case GT:
v1 = eval(env, s->sexp.s1);
v2 = eval(env, s->sexp.s2);
if(v1.type == VINT &&
v2.type == VINT)
return value_bool(v1.v > v2.v);
else
return value_err(v1, v2, 1);
case EQ:
v1 = eval(env, s->sexp.s1);
v2 = eval(env, s->sexp.s2);
if(v1.type == VINT &&
v2.type == VINT)
return value_bool(v1.v == v2.v);
else
return value_err(v1, v2, 1);
case IF:
v1 = eval(env, s->sexp.s1);
if(v1.type == VBOOL)
if(v1.b)
return eval(env, s->sexp.s2);
else
return eval(env, s->sexp.s3);
else
return value_err(v1, v1, 1);
case LET:
v1 = eval(env, s->sexp.s2);
if (v1.type == VERR) {
return v1;
}
return eval(env_add(env, s->sexp.s1->atom_n, eval(env, s->sexp.s2)), s->sexp.s3);
}
}
}
char line[256];
int pos;
char tok[16];
void run(struct sexp *s)
{
struct value v = eval(env0(), s);
if(v.type == VINT)
printf("%d\n", v.v);
else if(v.type == VBOOL)
printf("%s\n", v.b ? "true" : "false");
else {
if(v.v == 1)
printf("Type Mismatch\n");
else if (v.v == 2)
printf("Division By Zero\n");
else
printf("Unbound Identifier\n");
}
}
void lex()
{
int i;
tok[0] = 0;
while(line[pos] == ' ')
pos++;
switch(line[pos]) {
case '(':
case ')':
case '+':
case '-':
case '*':
case '/':
case '<':
case '>':
case '=':
tok[0] = line[pos];
tok[1] = 0;
pos++;
return;
default:
i = 0;
if(line[pos] >= '0' && line[pos] <= '9') {
while(line[pos] >= '0' && line[pos] <= '9')
tok[i++] = line[pos++];
tok[i] = 0;
return;
}
if(line[pos] >= 'a' && line[pos] <= 'z') {
while(line[pos] >= 'a' && line[pos] <= 'z')
tok[i++] = line[pos++];
tok[i] = 0;
return;
}
}
}
int
eval_instruction(struct vm_context **ctx)
{
struct symbol *sym;
struct object *value;
struct compound_proc *template;
switch (INS_AT((*ctx)->pc)->op) {
case NONE:
printf("Error: tried to execute a NONE op\n");
exit(1);
break;
case PUSH:
/* printf("PUSH instruction\n"); */
stack_push((*ctx)->stk, INS_AT((*ctx)->pc)->arg);
INC_REF(INS_AT((*ctx)->pc)->arg);
++(*ctx)->pc->offset;
break;
case POP:
/* printf("POP instruction\n"); */
value = stack_pop((*ctx)->stk);
DEC_REF(value);
++(*ctx)->pc->offset;
break;
case LOOKUP:
/* printf("LOOKUP instruction\n"); */
assert(INS_AT((*ctx)->pc)->arg->type->code == SYMBOL_TYPE);
sym = container_of(INS_AT((*ctx)->pc)->arg, struct symbol, obj);
value = env_lookup((*ctx)->env, sym->value);
if (! value) {
char buf[1024];
debug_loc_str(INS_AT((*ctx)->pc)->arg, buf, 1024);
printf("%s: unbound name: %s\n", buf, sym->value);
exit(1);
}
stack_push((*ctx)->stk, value);
INC_REF(value);
++(*ctx)->pc->offset;
break;
case CALL:
case TAILCALL:
/* printf("CALL instruction @ %p\n", *pc); */
eval_call(ctx);
break;
case RET:
value = stack_pop((*ctx)->stk);
struct object *orig_env = stack_pop((*ctx)->stk);
assert(orig_env->type->code == ENVIRONMENT_TYPE);
DEC_REF(orig_env);
struct object *retaddr = stack_pop((*ctx)->stk);
/* printf("RET instruction @ %p to %p\n", *pc, retaddr->cval); */
stack_push((*ctx)->stk, value);
DEC_REF(&(*ctx)->env->obj);
(*ctx)->env = container_of(orig_env, struct environment, obj);
if (retaddr == NULL) {
(*ctx)->pc = NULL;
return 1;
}
assert(retaddr->type->code == CODEPTR_TYPE);
*(*ctx)->pc = *container_of(retaddr, struct codeptr, obj);
/* XXX: */
/* DEC_REF(retaddr); */
break;
case DEFINE:
/* printf("DEFINE instruction\n"); */
value = stack_pop((*ctx)->stk);
assert(INS_AT((*ctx)->pc)->arg->type->code == SYMBOL_TYPE);
sym = container_of(INS_AT((*ctx)->pc)->arg, struct symbol, obj);
env_define((*ctx)->env, sym->value, value);
DEC_REF(value);
++(*ctx)->pc->offset;
break;
case SET:
value = stack_pop((*ctx)->stk);
assert(INS_AT((*ctx)->pc)->arg->type->code == SYMBOL_TYPE);
sym = container_of(INS_AT((*ctx)->pc)->arg, struct symbol, obj);
env_set((*ctx)->env, sym->value, value);
DEC_REF(value);
++(*ctx)->pc->offset;
break;
case LAMBDA:
/* printf("LAMBDA instruction\n"); */
value = INS_AT((*ctx)->pc)->arg;
assert(INS_AT((*ctx)->pc)->arg->type->code == PROCEDURE_TYPE);
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);
}
}
}
// returns NULL if not done yet
Obj *bytecode_eval_internal(Process *process, Obj *bytecodeObj, int steps) {
Obj *literal, *function, *lookup, *result, *bindings, *let_env, *binding;
int arg_count, i, bindings_index, body_index;
for(int step = 0; step < steps; step++) {
if(eval_error) {
return nil;
}
Obj **literals_array = process->frames[process->frame].bytecodeObj->bytecode_literals->array;
char *bytecode = process->frames[process->frame].bytecodeObj->bytecode;
int p = process->frames[process->frame].p;
char c = bytecode[p];
//printf("frame = %d, c = %c\n", frame, c);
switch(c) {
case 'l':
i = bytecode[p + 1] - 65;
literal = literals_array[i];
//printf("Pushing literal "); obj_print_cout(literal); printf("\n");
stack_push(process, literal);
process->frames[process->frame].p += 2;
break;
case 'd':
i = bytecode[p + 1] - 65;
literal = literals_array[i];
result = env_extend(process->global_env, literal, stack_pop(process));
stack_push(process, result->cdr);
process->frames[process->frame].p += 2;
break;
case 'n':
if(is_true(stack_pop(process))) {
stack_push(process, lisp_false);
} else {
stack_push(process, lisp_true);
}
process->frames[process->frame].p += 1;
break;
case 'r':
i = bytecode[p + 1] - 65;
literal = literals_array[i];
binding = env_lookup_binding(process, process->frames[process->frame].env, literal);
if(binding->car) {
//printf("binding: %s\n", obj_to_string(process, binding)->s);
binding->cdr = stack_pop(process);
stack_push(process, binding->cdr);
} else {
eval_error = obj_new_string("reset! can't find variable to reset: ");
obj_string_mut_append(eval_error, obj_to_string(process, literal)->s);
return nil;
}
process->frames[process->frame].p += 2;
break;
case 't':
//printf("entering let\n");
//shadow_stack_push(process, let_env);
bindings_index = bytecode[p + 1] - 65;
body_index = bytecode[p + 2] - 65;
bindings = literals_array[bindings_index];
//printf("bindings: %s\n", obj_to_string(process, bindings)->s);
let_env = obj_new_environment(process->frames[process->frame].env);
for(int i = 0; i < bindings->count; i++) {
env_extend(let_env, bindings->array[i], stack_pop(process));
}
process->frames[process->frame].p += 3;
process->frames[process->frame + 1].p = 0;
process->frames[process->frame + 1].bytecodeObj = literals_array[body_index];
process->frames[process->frame + 1].env = let_env;
process->frame++;
//printf("will now execute: %s\n", obj_to_string(process, process->frames[process->frame].bytecodeObj)->s);
break;
case 'y':
i = bytecode[p + 1] - 65;
literal = literals_array[i];
//printf("Looking up literal "); obj_print_cout(literal); printf("\n");
lookup = env_lookup(process, process->frames[process->frame].env, literal);
if(!lookup) {
set_error_return_nil("Failed to lookup ", literal);
}
stack_push(process, lookup);
process->frames[process->frame].p += 2;
break;
case 'i':
i = bytecode[p + 1] - 65;
if(is_true(stack_pop(process))) {
process->frames[process->frame].p = 0;
process->frames[process->frame].bytecodeObj = literals_array[i];
process->frames[process->frame].env = process->frames[process->frame - 1].env;
}
else {
process->frames[process->frame].p = 0;
process->frames[process->frame].bytecodeObj = literals_array[i + 1];
process->frames[process->frame].env = process->frames[process->frame - 1].env;
}
break;
case 'c':
function = stack_pop(process);
arg_count = bytecode[p + 1] - 65;
Obj **args = NULL;
if(arg_count > 0) {
args = malloc(sizeof(Obj*) * arg_count);
}
for(int i = 0; i < arg_count; i++) {
Obj *arg = stack_pop(process);
args[arg_count - i - 1] = arg;
//shadow_stack_push(process, arg);
}
process->frames[process->frame].p += 2;
if(function->tag == 'P') {
stack_push(process, function->primop((struct Process*)process, args, arg_count));
}
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 == 'L') {
Obj *calling_env = obj_new_environment(function->env);
//printf("arg_count = %d\n", arg_count);
env_extend_with_args(process, calling_env, function, arg_count, args, true);
process->frame++;
process->frames[process->frame].p = 0;
if(function->body->tag != 'X') {
set_error_return_nil("The body of the lambda must be bytecode, ", function);
}
process->frames[process->frame].bytecodeObj = function->body;
process->frames[process->frame].env = calling_env;
//printf("Pushing new stack frame with bytecode '%s'\n", process->frames[process->frame].bytecode); // and env %s\n", process->frames[process->frame].bytecode, obj_to_string(process, calling_env)->s);
}
else {
printf("Can't handle other calling methods yet %c\n", function->tag);
obj_print_cout(function);
return nil;
}
break;
case 'q':
process->frame--;
if(process->frame < 0) {
goto done;
}
break;
default:
printf("Unhandled instruction: %c\n", c);
exit(-1);
}
}
done:;
return stack_pop(process);
}
static value_t *e_expr(env_t *env, expr_t *expr)
{
value_t *result;
switch (expr->type) {
default: // This is to handle invalid tags.
case p_unused:
if (*(int *)NULL) {
printf("should crash.\n");
}
return NULL;
case p_and:
{
value_t *l = e_expr(env, binary_left(expr));
if (bool_val(l)) {
result = e_expr(env, binary_right(expr));
} else {
result = l;
}
}
break;
case p_or:
{
value_t *l = e_expr(env, binary_left(expr));
if (bool_val(l)) {
result = l;
} else {
result = e_expr(env, binary_right(expr));
}
}
break;
case p_add:
case p_div:
case p_ge:
case p_gt:
case p_le:
case p_lt:
case p_mod:
case p_mul:
case p_sub:
result = e_binary_op(env, expr);
break;
case p_bconst:
result = alloc_value(v_bool);
bool_val(result) = bool_val(expr);
break;
case p_cconst:
result = alloc_value(v_char);
char_val(result) = char_val(expr);
break;
case p_datacons:
result = e_datacons(env, expr);
break;
case p_eqop:
result = e_equals(env, binary_left(expr), binary_right(expr));
break;
case p_fncall:
result = e_fncall(env, fncall_fn(expr), fncall_args(expr));
break;
case p_nconst:
result = alloc_value(v_num);
num_val(result) = num_val(expr);
break;
case p_ite:
result = e_ite(env, expr);
break;
case p_let:
result = e_let(env, expr);
break;
case p_listcons:
result = e_listcons(env, expr);
break;
case p_listlit:
result = e_listlit(env, expr);
break;
case p_listempty:
result = e_listempty();
break;
case p_match:
result = e_match(env, expr);
break;
case p_ne:
result = e_equals(env, binary_left(expr), binary_right(expr));
bool_val(result) = !bool_val(result);
break;
case p_negate:
result = e_expr(env, unary_expr(expr));
bool_val(result) = !bool_val(result);
break;
case p_tuple:
result = e_tuple(env, expr);
break;
case p_var:
result = env_lookup(env, var_name(expr));
if (result == NULL) {
error("e_expr: variable '%s' not in scope on line %d.\n", var_name(expr), expr->line_num);
}
result = thunk_force(result);
break;
}
return result;
}
struct atom *eval(struct atom *expr, struct env *env)
{
// symbols and not-a-lists are evaluated or returned directly
if (IS_SYM(expr))
{
struct atom *atom = env_lookup(env, expr->str.str);
if (atom)
{
return atom;
}
else
{
printf("error: undefined variable: %s\n",
expr->str.str);
return &nil_atom;
}
}
if (!IS_LIST(expr))
return expr;
struct list *list = expr->list;
struct atom *op = LIST_FIRST(list);
// Check if the first elem is not a symbol or a closure. If it's
// not, then we'll evaluate it (it could be a lambda form).
if (!IS_SYM(op) && !IS_CLOSURE(op))
{
struct atom *evaluated_op = eval(op, env);
// Replace the evaluated one to the list!
LIST_REMOVE(op, entries);
LIST_INSERT_HEAD(list, evaluated_op, entries);
op = evaluated_op;
}
// If the first elem is a symbol, it should be a name for a builtin
// function or a closure bound to that name by the user. If the
// first argument is directly a closure, eval that with the args.
if (IS_SYM(op))
{
struct builtin_function_def *def = builtin_function_defs;
while (def->name && def->fn)
{
if (strcmp(op->str.str, def->name) == 0)
{
return def->fn(expr, env);
}
++def;
}
struct atom *closure = env_lookup(env, op->str.str);
if (closure)
{
return eval_closure(closure, CDR(op), env);
}
printf("error: unknown function %s\n", op->str.str);
}
else if (IS_CLOSURE(op))
{
return eval_closure(op, CDR(op), env);
}
printf("error: cannot evaluate\n");
return &nil_atom;
}
static obj_t *eval_symbol(void)
{
obj_t *binding = env_lookup(F_ENV, F_SUBJ);
return binding_value(binding);
}
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);
}
}
data_declaration interface_lookup(data_declaration iref, const char *name)
{
return env_lookup(iref->functions->id_env, name, FALSE);
}
