void exec_assignment(env_t* env, ast_t* ast) {
ast_t* right = NULL;
switch(ast->data.assignment.right->type) {
case at_function:
right = ast->data.assignment.right;
break;
case at_bool:
case at_double:
case at_integer:
case at_string:
case at_statements:
right = ast->data.assignment.right;
break;
case at_identifier:
right = get_ast_by_id(env, ast->data.assignment.right->data.id);
break;
case at_expression:
right = eval_expression(env, ast->data.assignment.right);
break;
case at_call:
right = eval_call(env, ast->data.assignment.right);
break;
default:
break;
}
if(right == NULL) {
error_assign(NULL,"NULL",ast->data.assignment.id);
}
set_ast_to_id(env, ast->data.assignment.id, right);
}
/**
Evaluate the source code in a given string
This can also be used to evaluate files
*/
value_t eval_unit(ast_fun_t* unit_fun)
{
assert (unit_fun != NULL);
if (unit_fun == NULL)
{
printf("unit failed to parse\n");
exit(-1);
}
// Resolve all variables in the unit
var_res_pass(unit_fun, vm.global_clos? vm.global_clos->fun:NULL);
// Create the unit closure by evaluating the unit function expression
// This will resolve the free variables for this unit
value_t unit_clos = eval_expr(
(heapptr_t)unit_fun,
vm.global_clos,
NULL
);
// Call the unit function with no arguments
return eval_call(
unit_clos.word.clos,
array_alloc(0),
NULL,
NULL
);
}
void exec_statements(env_t* env, ast_t* ast) {
size_t i;
for(i = 0; i < ast->data.statements.count; i++) {
switch(ast->data.statements.statements[i]->type) {
case at_assignment:
exec_assignment(env, ast->data.statements.statements[i]);
break;
case at_call: {
ast_t* tmp = eval_call(env, ast->data.statements.statements[i]);
if(tmp != NULL) {
if(tmp->ref_count == 0) {
free_ast(tmp);
}
}
break;
}
case at_conditional:
exec_conditional(env, ast->data.statements.statements[i]);
break;
case at_while:
exec_while(env, ast->data.statements.statements[i]);
break;
case at_dowhile:
exec_dowhile(env, ast->data.statements.statements[i]);
break;
default:
error_unexpected(NULL,get_ast_type_name(ast->data.statements.statements[i]->type));
break;
}
}
}
// Compute the multi-step evaluation of the term t.
Term*
eval(Term* t) {
switch (t->kind) {
case if_term: return eval_if(as<If>(t));
case succ_term: return eval_succ(as<Succ>(t));
case pred_term: return eval_pred(as<Pred>(t));
case iszero_term: return eval_iszero(as<Iszero>(t));
case app_term: return eval_app(as<App>(t));
case call_term: return eval_call(as<Call>(t));
case ref_term: return eval_ref(as<Ref>(t));
case print_term: return eval_print(as<Print>(t));
case def_term: return eval_def(as<Def>(t));
case prog_term: return eval_prog(as<Prog>(t));
case comma_term: return eval_comma(as<Comma>(t));
default: break;
}
return t;
}
ast_t* eval_expression(env_t* env, ast_t* ast) {
switch(ast->type) {
/* valid */
case at_call: return eval_call(env,ast);
case at_identifier: return get_ast_by_id(env, ast->data.id);
case at_expression: {
ast_t* result = NULL;
ast_t* left = eval_expression(env, ast->data.expression.left);
ast_t* right = eval_expression(env, ast->data.expression.right);
inc_ref(left);
inc_ref(right);
switch(ast->data.expression.op) {
case op_add: result = eval_add(env, left, right); break;
case op_mul: result = eval_mul(env, left, right); break;
case op_div: result = eval_div(env, left, right); break;
case op_sub: result = eval_sub(env, left, right); break;
case op_mod: result = eval_mod(env, left, right); break;
case op_and: result = eval_and(env, left, right); break;
case op_or: result = eval_or(env, left, right); break;
case op_gt: result = eval_gt(env, left, right); break;
case op_ge: result = eval_ge(env, left, right); break;
case op_lt: result = eval_lt(env, left, right); break;
case op_le: result = eval_le(env, left, right); break;
case op_eq: result = eval_eq(env, left, right); break;
case op_neq: result = eval_neq(env, left, right); break;
case op_cat: result = eval_cat(env, left, right); break;
case op_deref: {
ast_t* index = eval_expression(env, right);
if (index->type != at_integer) {
// TODO: error -> index must be an integer!
} else {
switch(left->type) {
case at_list: result = left->data.list.elements[index->data.i];
}
}
}
}
result->ref_count = 0;
dec_ref(left);
dec_ref(right);
return result;
}
/* no need to evaluate */
case at_integer:
case at_bool:
case at_double:
case at_string:
case at_function:
case at_statements:
case at_list:
return ast;
/* invalid */
case at_assignment:
case at_callargs:
case at_conditional:
case at_dowhile:
case at_elif:
case at_if:
case at_params:
case at_while:
case at_builtin:
error_expected(NULL,"expression",get_ast_type_name(ast->type));
}
return NULL; /* this should never happen */
}
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);
static struct block *postfix_expression(struct block *block)
{
struct var root;
block = primary_expression(block);
root = block->expr;
while (1) {
const struct member *field;
const struct typetree *type;
struct var expr, copy, *arg;
struct token tok;
int i, j;
switch ((tok = peek()).token) {
case '[':
do {
/* Evaluate a[b] = *(a + b). The semantics of pointer arithmetic
* takes care of multiplying b with the correct width. */
consume('[');
block = expression(block);
root = eval_expr(block, IR_OP_ADD, root, block->expr);
root = eval_deref(block, root);
consume(']');
} while (peek().token == '[');
break;
case '(':
type = root.type;
if (is_pointer(root.type) && is_function(root.type->next))
type = type_deref(root.type);
else if (!is_function(root.type)) {
error("Expression must have type pointer to function, was %t.",
root.type);
exit(1);
}
consume('(');
arg = calloc(nmembers(type), sizeof(*arg));
for (i = 0; i < nmembers(type); ++i) {
if (peek().token == ')') {
error("Too few arguments, expected %d but got %d.",
nmembers(type), i);
exit(1);
}
block = assignment_expression(block);
arg[i] = block->expr;
/* todo: type check here. */
if (i < nmembers(type) - 1) {
consume(',');
}
}
while (is_vararg(type) && peek().token != ')') {
consume(',');
arg = realloc(arg, (i + 1) * sizeof(*arg));
block = assignment_expression(block);
arg[i] = block->expr;
i++;
}
consume(')');
for (j = 0; j < i; ++j)
param(block, arg[j]);
free(arg);
root = eval_call(block, root);
break;
case '.':
consume('.');
tok = consume(IDENTIFIER);
field = find_type_member(root.type, tok.strval);
if (!field) {
error("Invalid field access, no member named '%s'.",
tok.strval);
exit(1);
}
root.type = field->type;
root.offset += field->offset;
break;
case ARROW:
consume(ARROW);
tok = consume(IDENTIFIER);
if (is_pointer(root.type) && is_struct_or_union(root.type->next)) {
field = find_type_member(type_deref(root.type), tok.strval);
if (!field) {
error("Invalid field access, no member named '%s'.",
tok.strval);
exit(1);
}
/* Make it look like a pointer to the field type, then perform
* normal dereferencing. */
root.type = type_init(T_POINTER, field->type);
root = eval_deref(block, root);
root.offset = field->offset;
} else {
error("Invalid field access.");
exit(1);
}
break;
case INCREMENT:
consume(INCREMENT);
copy = create_var(root.type);
eval_assign(block, copy, root);
expr = eval_expr(block, IR_OP_ADD, root, var_int(1));
eval_assign(block, root, expr);
root = copy;
break;
case DECREMENT:
consume(DECREMENT);
copy = create_var(root.type);
eval_assign(block, copy, root);
expr = eval_expr(block, IR_OP_SUB, root, var_int(1));
eval_assign(block, root, expr);
root = copy;
break;
default:
block->expr = root;
return block;
}
}
}
/**
Evaluate an expression in a given frame
*/
value_t eval_expr(
heapptr_t expr,
clos_t* clos,
value_t* locals
)
{
//printf("eval_expr\n");
// Get the shape of the AST node
// Note: AST nodes must match the shapes defined in init_parser,
// otherwise this interpreter can't handle it
shapeidx_t shape = get_shape(expr);
// Variable or constant declaration (let/var)
if (shape == SHAPE_AST_DECL)
{
ast_decl_t* decl = (ast_decl_t*)expr;
// Let declarations should be initialized
assert (decl->cst == false);
return VAL_FALSE;
}
// Variable reference (read)
if (shape == SHAPE_AST_REF)
{
ast_ref_t* ref = (ast_ref_t*)expr;
assert (ref->decl != NULL);
//printf("evaluating ref to %s\n", string_cstr(ref->name));
// If this is a variable from an outer function
if (ref->decl->fun != clos->fun)
{
//printf("ref from outer fun\n");
assert (ref->idx < clos->fun->free_vars->len);
cell_t* cell = clos->cells[ref->idx];
assert (cell != NULL);
value_t value;
value.word = cell->word;
value.tag = cell->tag;
return value;
}
// Check that the ref index is valid
if (ref->idx > clos->fun->local_decls->len)
{
printf("invalid variable reference\n");
printf("ref->name=%s\n", string_cstr(ref->name));
printf("ref->idx=%d\n", ref->idx);
printf("local_decls->len=%d\n", clos->fun->local_decls->len);
exit(-1);
}
// If this an escaping variable (captured by a closure)
if (ref->decl->esc)
{
// Free variables are stored in mutable cells
// Pointers to the cells are found on the closure object
cell_t* cell = locals[ref->idx].word.cell;
value_t value;
value.word = cell->word;
value.tag = cell->tag;
//printf("read value from cell\n");
return value;
}
/*
printf("reading normal local\n");
string_print(ref->name);
printf("\n");
*/
// Read directly from the stack frame
return locals[ref->idx];
}
if (shape == SHAPE_AST_CONST)
{
//printf("constant\n");
ast_const_t* cst = (ast_const_t*)expr;
return cst->val;
}
if (shape == SHAPE_STRING)
{
return value_from_heapptr(expr, TAG_STRING);
}
// Array literal expression
if (shape == SHAPE_ARRAY)
{
array_t* array_expr = (array_t*)expr;
// Array of values to be produced
array_t* val_array = array_alloc(array_expr->len);
for (size_t i = 0; i < array_expr->len; ++i)
{
heapptr_t expr = array_get(array_expr, i).word.heapptr;
value_t value = eval_expr(expr, clos, locals);
array_set(val_array, i, value);
}
return value_from_heapptr((heapptr_t)val_array, TAG_ARRAY);
}
// Object literal expression
if (shape == SHAPE_AST_OBJ)
{
//printf("obj literal expr\n");
ast_obj_t* obj_expr = (ast_obj_t*)expr;
object_t* obj = object_alloc(OBJ_MIN_CAP);
// TODO: set prototype
// Do this in object_alloc?
for (size_t i = 0; i < obj_expr->name_strs->len; ++i)
{
string_t* prop_name = array_get(obj_expr->name_strs, i).word.string;
heapptr_t val_expr = array_get(obj_expr->val_exprs, i).word.heapptr;
value_t value = eval_expr(val_expr, clos, locals);
object_set_prop(
obj,
prop_name,
value,
ATTR_DEFAULT
);
}
return value_from_obj((heapptr_t)obj);
}
// Binary operator (e.g. a + b)
if (shape == SHAPE_AST_BINOP)
{
//printf("binop\n");
ast_binop_t* binop = (ast_binop_t*)expr;
// Assignment
if (binop->op == &OP_ASSIGN)
{
value_t val = eval_expr(binop->right_expr, clos, locals);
return eval_assign(
binop->left_expr,
val,
clos,
locals
);
}
value_t v0 = eval_expr(binop->left_expr, clos, locals);
value_t v1 = eval_expr(binop->right_expr, clos, locals);
int64_t i0 = v0.word.int64;
int64_t i1 = v1.word.int64;
string_t* s0 = v0.word.string;
string_t* s1 = v1.word.string;
if (binop->op == &OP_MEMBER)
return eval_get_prop(v0, v1);
if (binop->op == &OP_INDEX)
return eval_get_index(v0, v1);
if (binop->op == &OP_ADD)
return value_from_int64(i0 + i1);
if (binop->op == &OP_SUB)
return value_from_int64(i0 - i1);
if (binop->op == &OP_MUL)
return value_from_int64(i0 * i1);
if (binop->op == &OP_DIV)
return value_from_int64(i0 / i1);
if (binop->op == &OP_MOD)
return value_from_int64(i0 % i1);
if (binop->op == &OP_LT)
return (i0 < i1)? VAL_TRUE:VAL_FALSE;
if (binop->op == &OP_LE)
{
if (v0.tag == TAG_STRING && v1.tag == TAG_STRING)
return (strcmp(string_cstr(s0), string_cstr(s1)) <= 0)? VAL_TRUE:VAL_FALSE;
if (v0.tag == TAG_INT64 && v1.tag == TAG_INT64)
return (i0 <= i1)? VAL_TRUE:VAL_FALSE;
assert (false);
}
if (binop->op == &OP_GT)
return (i0 > i1)? VAL_TRUE:VAL_FALSE;
if (binop->op == &OP_GE)
{
if (v0.tag == TAG_STRING && v1.tag == TAG_STRING)
return (strcmp(string_cstr(s0), string_cstr(s1)) >= 0)? VAL_TRUE:VAL_FALSE;
if (v0.tag == TAG_INT64 && v1.tag == TAG_INT64)
return (i0 >= i1)? VAL_TRUE:VAL_FALSE;
assert (false);
}
if (binop->op == &OP_EQ)
return value_equals(v0, v1)? VAL_TRUE:VAL_FALSE;
if (binop->op == &OP_NE)
return value_equals(v0, v1)? VAL_FALSE:VAL_TRUE;
printf("unimplemented binary operator: %s\n", binop->op->str);
return VAL_FALSE;
}
// Unary operator (e.g.: -x, not a)
if (shape == SHAPE_AST_UNOP)
{
ast_unop_t* unop = (ast_unop_t*)expr;
value_t v0 = eval_expr(unop->expr, clos, locals);
if (unop->op == &OP_NEG)
return value_from_int64(-v0.word.int64);
if (unop->op == &OP_NOT)
return eval_truth(v0)? VAL_FALSE:VAL_TRUE;
printf("unimplemented unary operator: %s\n", unop->op->str);
return VAL_FALSE;
}
// Sequence/block expression
if (shape == SHAPE_AST_SEQ)
{
ast_seq_t* seqexpr = (ast_seq_t*)expr;
array_t* expr_list = seqexpr->expr_list;
value_t value = VAL_TRUE;
for (size_t i = 0; i < expr_list->len; ++i)
{
heapptr_t expr = array_get(expr_list, i).word.heapptr;
value = eval_expr(expr, clos, locals);
}
// Return the value of the last expression
return value;
}
// If expression
if (shape == SHAPE_AST_IF)
{
ast_if_t* ifexpr = (ast_if_t*)expr;
value_t t = eval_expr(ifexpr->test_expr, clos, locals);
if (eval_truth(t))
return eval_expr(ifexpr->then_expr, clos, locals);
else
return eval_expr(ifexpr->else_expr, clos, locals);
}
// Function/closure expression
if (shape == SHAPE_AST_FUN)
{
//printf("creating closure\n");
ast_fun_t* nested = (ast_fun_t*)expr;
// Allocate a closure of the nested function
clos_t* new_clos = clos_alloc(nested);
// For each free (closure) variable of the nested function
for (size_t i = 0; i < nested->free_vars->len; ++i)
{
ast_decl_t* decl = array_get(nested->free_vars, i).word.decl;
// If the variable is from this function
if (decl->fun == clos->fun)
{
new_clos->cells[i] = locals[decl->idx].word.cell;
}
else
{
uint32_t free_idx = array_indexof_ptr(clos->fun->free_vars, (heapptr_t)decl);
assert (free_idx < clos->fun->free_vars->len);
new_clos->cells[i] = clos->cells[free_idx];
}
}
assert (new_clos->fun == nested);
return value_from_heapptr((heapptr_t)new_clos, TAG_CLOS);
}
// Call expression
if (shape == SHAPE_AST_CALL)
{
//printf("evaluating call\n");
ast_call_t* callexpr = (ast_call_t*)expr;
// Evaluate the closure expression
value_t callee_clos = eval_expr(callexpr->fun_expr, clos, locals);
if (callee_clos.tag == TAG_CLOS)
{
return eval_call(
callee_clos.word.clos,
callexpr->arg_exprs,
clos,
locals
);
}
if (callee_clos.tag == TAG_HOSTFN)
{
return eval_host_call(
callee_clos.word.hostfn,
callexpr->arg_exprs,
clos,
locals
);
}
printf("invalid callee in function call\n");
exit(-1);
}
printf("eval error, unknown expression type, shapeidx=%d\n", get_shape(expr));
exit(-1);
}
