static void
call_crowbar_function(SIMCAR_Interpreter *inter, SIMCAR_LocalEnvironment *env,
SIMCAR_LocalEnvironment *caller_env,
Expression *expr, FunctionDefinition *func)
{
SIMCAR_Value value;
StatementResult result;
ArgumentList *arg_p;
ParameterList *param_p;
for (arg_p = expr->u.function_call_expression.argument,
param_p = func->u.crowbar_f.parameter;
arg_p;
arg_p = arg_p->next, param_p = param_p->next) {
Variable *new_var;
SIMCAR_Value arg_val;
if (param_p == NULL) {
crb_runtime_error(expr->line_number, ARGUMENT_TOO_MANY_ERR,
MESSAGE_ARGUMENT_END);
}
eval_expression(inter, caller_env, arg_p->expression);
arg_val = pop_value(inter);
new_var = crb_add_local_variable(env, param_p->name);
new_var->value = arg_val;
}
if (param_p) {
crb_runtime_error(expr->line_number, ARGUMENT_TOO_FEW_ERR,
MESSAGE_ARGUMENT_END);
}
result = crb_execute_statement_list(inter, env,
func->u.crowbar_f.block
->statement_list);
if (result.type == RETURN_STATEMENT_RESULT) {
value = result.u.return_value;
} else {
value.type = SIMCAR_NULL_VALUE;
}
push_value(inter, &value);
}
CRB_Value
crb_eval_minus_expression(CRB_Interpreter *inter, LocalEnviroment *env,
Expression *operand)
{
CBR_Value operand_val;
CRB_Value result;
operand_val = eval_expression(inter, env, operand);
if(operand_val.type == CRB_INT_VALUE){
resul.type = CRB_INT_VALUE;
result.u.int_value = -oprand_val.u.int_value;
} else if(oeprand_val.type == CRB_DOUBLE_VALUE){
result.type = CRB_DOUBLE_VALUE;
result.u.double_value = -operand_val.u.double_value;
} else {
crb_runtime_error(operand->line_number, MINUS_OPERAND_TYPE_ERR,
MESSAGE_ARGUMENT_END);
}
return result;
}
void if_command(wchar_t *line)
{
wchar_t if_expr[BUFFER_SIZE],
if_then[BUFFER_SIZE],
if_else[BUFFER_SIZE],
temp[BUFFER_SIZE];
line=get_arg_in_braces(line,if_expr,STOP_SPACES,sizeof(if_expr)/sizeof(wchar_t)-1);
substitute_vars(if_expr,temp, sizeof(temp)/sizeof(wchar_t));substitute_myvars(temp,if_expr, sizeof(if_expr)/sizeof(wchar_t));
line=get_arg_in_braces(line,if_then,WITH_SPACES,sizeof(if_then)/sizeof(wchar_t)-1);
substitute_vars(if_then,temp, sizeof(temp)/sizeof(wchar_t));substitute_myvars(temp,if_then, sizeof(if_then)/sizeof(wchar_t));
line=get_arg_in_braces(line,if_else,WITH_SPACES,sizeof(if_else)/sizeof(wchar_t)-1);
substitute_vars(if_else,temp, sizeof(temp)/sizeof(wchar_t));substitute_myvars(temp,if_else, sizeof(if_else)/sizeof(wchar_t));
wchar_t *to_parse = eval_expression(if_expr) ? if_then : if_else;
if( to_parse && wcslen(to_parse) ) {
parse_input(to_parse);
}
}
static CRB_Value
call_crowbar_function(CRB_Interpreter *inter, LocalEnvironment *env,
Expression *expr, FunctionDefinition *func)
{
CRB_Value value;
StatementList result;
ArgumentList *arg_p;
ParamenterList *param_p;
LocalEnvironment *local_env;
local_env = alloc_local_envroment();
for(arg_p = expr->u.function_call_expression.argument,
param_p = func->u.crowbar_f.parameter;
arg_p;
arg_p = arg->next, param_p = param_p->next){
CRB_Value arg_val;
if(param_p == NULL){
crb_runtime_error(expr->line_number, ARGUMENT_TOO_MANY_ERR,
MESSAGE_ARGUMENT_END);
}
arg_val = eval_expression(inter, env, arg_p->expression);
crb_add_local_variable(local_env, param_p->name, &arg_val);
}
if(param_p){
crb_runtime_error(expr->line_number, ARGUMENT_TOO_FEW_ERR,
MESSAGE_ARUMENT_END);
}
result = crb_execute_statement_list(inter, local_env,
func->u.crowbar_f.block
->statement_list);
if(result.type == RETURN_STATEMENT_RESULT){
value.type = result.u.return_value;
} else {
value.type = CRB_NULL_VALUE;
}
dispose_local_enviroment(inter, local_env);
return value;
}
static void
call_native_function(SIMCAR_Interpreter *inter, SIMCAR_LocalEnvironment *env,
SIMCAR_LocalEnvironment *caller_env,
Expression *expr, SIMCAR_NativeFunctionProc *proc)
{
SIMCAR_Value value;
int arg_count;
ArgumentList *arg_p;
SIMCAR_Value *args;
for (arg_count = 0, arg_p = expr->u.function_call_expression.argument;
arg_p; arg_p = arg_p->next) {
eval_expression(inter, caller_env, arg_p->expression);
arg_count++;
}
args = &inter->stack.stack[inter->stack.stack_pointer-arg_count];
value = proc(inter, env, arg_count, args);
shrink_stack(inter, arg_count);
push_value(inter, &value);
}
static void
eval_minus_expression(SIMCAR_Interpreter *inter, SIMCAR_LocalEnvironment *env,
Expression *operand)
{
SIMCAR_Value operand_val;
SIMCAR_Value result;
eval_expression(inter, env, operand);
operand_val = pop_value(inter);
if (operand_val.type == SIMCAR_INT_VALUE) {
result.type = SIMCAR_INT_VALUE;
result.u.int_value = -operand_val.u.int_value;
} else if (operand_val.type == SIMCAR_DOUBLE_VALUE) {
result.type = SIMCAR_DOUBLE_VALUE;
result.u.double_value = -operand_val.u.double_value;
} else {
crb_runtime_error(operand->line_number, MINUS_OPERAND_TYPE_ERR,
MESSAGE_ARGUMENT_END);
}
push_value(inter, &result);
}
static
void eval_interpolation_string(const char ** begin, const char * end,
const std::vector<const char *> & interpolations,
command_stack & command)
{
const char * start = *begin;
std::size_t cmd_index = command.push_command();
command.push_argument_symbol("@", 1);
std::size_t length = interpolations[0] - start;
if(length) command.push_argument(start, length);
typedef std::vector<const char *>::const_iterator iterator;
for(iterator iter = interpolations.begin(); iter != interpolations.end();
iter++)
{
const char * cursor = *iter;
for(; *cursor == '@' && cursor != end; cursor++);
if(*cursor == '(') eval_expression(&cursor, end, command, true);
else eval_interpolation_symbol(&cursor, end, command);
if(cursor + 1 < end)
{
const char * sub_end = end;
if(iter + 1 != interpolations.end())
sub_end = *(iter + 1);
cursor++;
length = sub_end - cursor;
if(length) command.push_argument(cursor, length);
}
}
command.call(cmd_index);
}
static void
eval_array_expression(SIMCAR_Interpreter *inter,
SIMCAR_LocalEnvironment *env, ExpressionList *list)
{
SIMCAR_Value v;
int size;
ExpressionList *pos;
int i;
size = 0;
for (pos = list; pos; pos = pos->next) {
size++;
}
v.type = SIMCAR_ARRAY_VALUE;
v.u.object = crb_create_array_i(inter, size);
push_value(inter, &v);
for (pos = list, i = 0; pos; pos = pos->next, i++) {
eval_expression(inter, env, pos->expression);
v.u.object->u.array.array[i] = pop_value(inter);
}
}
static inline lisp_obj *trampoline(lisp_obj *obj, lisp_err *err)
{
int i = 0;
while (obj && obj->type == THUNK){
lisp_expr *body = obj->value.l.declaration;
lisp_env *env = obj->value.l.context;
lisp_obj *res = eval_expression(body, env, err);
if (enable_debug && i > 0){
printf("Trampolined [%d] -> ", i);
lisp_print(res);
printf("\n");
}
release(obj);
obj = res;
i++;
}
if (enable_debug && i > 0){
printf("=== End of trampoline\n");
}
return obj;
}
static int eval_expression(value *val, node *expr, exec_env *env)
{
int tmp;
value left, right;
/* Not strictly speaking necessary I don't think, just don't want to
* deal with uninitiated stuff right now. */
tmp = 0;
memset(val, 0, sizeof(*val));
memset(&left, 0, sizeof(*val));
memset(&right, 0, sizeof(*val));
/* have to handle this first, since it is a terminal, but it
* has a left and a right operand. This way everything else
* can carry on unchanged.
*
* if this is going to get moved into the switch somehow, it's
* value in ast_defines.json has to be moved, so that the code
* will optomize into a jumptable.
*/
if(expr->type == AST_MAP_ACS) {
if(access_map(val, expr, env) < 0)
return -1;
/* convert non expressable types to value_error */
switch(val->type) {
case VALUE_NONE:
case VALUE_ERROR:
case VALUE_INT:
case VALUE_FLOAT:
case VALUE_SYMBOL:
case VALUE_STRING:
case VALUE_TYPE:
return 0;
break;
default:
memset(val, 0, sizeof(*val));
val->type = VALUE_ERROR;
return 1;
break;
}
assert(0);
return 0;
}
if(expr->left) {
if((tmp = eval_expression(&left, expr->left, env)) < 0)
return tmp;
if(left.type == VALUE_ERROR) {
*val = left;
return 1;
}
}
if (expr->right) {
if((tmp = eval_expression(&right, expr->right, env)) < 0)
return tmp;
if(right.type == VALUE_ERROR) {
*val = right;
return 1;
}
}
switch (expr->type) {
case AST_INT:
val->type = VALUE_INT;
val->n = expr->n;
break;
case AST_FLOAT:
val->type = VALUE_FLOAT;
val->x = expr->x;
break;
case AST_SYMBOL:
val->type = VALUE_SYMBOL;
val->sym = expr->sym;
break;
case AST_EXPR_ID:
if((tmp = lookup_symbol_value(val, expr->sym, env)) != 0) {
env->error.code = ERROR_INVALID_EXPRESSION;
env->error.line = expr->loc.line;
env->error.col = expr->loc.col;
env->error.file = env->lib->label;
env->error.static_msg = "unbound variable in expression";
return -1;
}
switch(val->type) {
case VALUE_NONE:
case VALUE_ERROR:
case VALUE_INT:
case VALUE_FLOAT:
case VALUE_SYMBOL:
case VALUE_STRING:
case VALUE_TYPE:
return tmp;
break;
default:
memset(val, 0, sizeof(*val));
val->type = VALUE_ERROR;
return 1;
break;
}
break;
case AST_STRING:
val->type = VALUE_STRING;
val->str = expr->str;
break;
case AST_NEG:
switch(left.type) {
case VALUE_INT:
*val = left;
val->n *= -1;
break;
case VALUE_FLOAT:
*val = left;
val->x *= -1;
break;
default:
env->error.code = ERROR_INVALID_EXPRESSION;
env->error.line = expr->loc.line;
env->error.col = expr->loc.col;
env->error.file = env->lib->label;
env->error.static_msg = "numerical expresssion not "
"involving floats or ints";
return -1;
break;
}
break;
/* note: the EGE macro is defined in error_macros.h,
* it means "on Error, Goto Error" with "error" being
* a magic goto label, given below. */
case AST_PLUS:
EGE(eval_bi_op('+', val, &left, &right));
break;
case AST_MINUS:
EGE(eval_bi_op('-', val, &left, &right));
break;
case AST_TIMES:
EGE(eval_bi_op('*', val, &left, &right));
break;
case AST_DIVIDE:
EGE(eval_bi_op('/', val, &left, &right));
break;
case AST_GREATER_THAN:
EGE(eval_bi_op('>', val, &left, &right));
break;
case AST_LESS_THAN:
EGE(eval_bi_op('<', val, &left, &right));
break;
case AST_EQUALITY:
val->type = VALUE_INT;
tmp = memcmp(&left, &right, sizeof(left));
val->n = !tmp;
break;
case AST_AND:
val->type = VALUE_INT;
val-> n = (is_true(&left) && is_true(&right)) ? 1 : 0;
break;
case AST_OR:
val->type = VALUE_INT;
val-> n = (is_true(&left) || is_true(&right)) ? 1 : 0;
break;
case AST_NOT:
val->type = VALUE_INT;
val-> n = is_true(&left) ? 0 : 1;
break;
default:
assert(0);
break;
}
return 0;
error:
env->error.code = ERROR_INVALID_EXPRESSION;
env->error.line = expr->loc.line;
env->error.col = expr->loc.col;
env->error.file = env->lib->label;
env->error.static_msg = "numerical expresssion error, likely bad types.";
return -1;
}
static int get_initialized_value (const enum init_type init_type, value *val,
node *init, exec_env *env)
{
int res;
value tmp, tmp2, none;
node *iter;
assert (val && init && env);
assert (init_type == INIT_MAP || init_type == INIT_SEQ);
if(init_type == INIT_SEQ) {
val->type = VALUE_SEQ;
val->seq = FIAL_create_seq();
if(!val->seq)
return -1;
if (FIAL_seq_reserve(val->seq, init->n) < 0)
return -1;
} else {
val->type = VALUE_MAP;
val->map = FIAL_create_symbol_map();
if(!val->map)
return -1;
}
memset(&none, 0, sizeof(none));
/* this coding style is a bit inelegant, but it seems simplest. If
* there were more than two alternative initializers, I would prefer
* this seperated out into different functions, this is about the
* limit of the complexity of decision logic that I want to deal
* with. */
for(iter = init->left; iter != NULL; iter = iter->right) {
/* just initializing the buggers at the top of the loop, this could
* maybe be skipped, but that would be an optomization that I don't
* need to mess with right now.
*/
tmp = tmp2 = none;
switch(iter->type) {
case AST_INIT_EXPRESSION:
if(eval_expression(&tmp, iter->left, env) < 0)
return -2;
if (init_type == INIT_SEQ) {
if( FIAL_seq_in(val->seq, &tmp) < 0) {
return -1;
}
} else {
if(FIAL_set_symbol(val->map, iter->sym,
&tmp, env->interp) < 0) {
return -1;
}
}
break;
case AST_INIT_INITIALIZER:
switch(iter->left->type) {
case AST_SEQ_INITIALIZER:
if((res = get_initialized_seq
(&tmp, iter->left, env)) < 0) {
return res;
}
break;
case AST_MAP_INITIALIZER:
if((res = get_initialized_map
(&tmp, iter->left, env)) < 0) {
return res;
}
break;
default:
assert(0);
break;
}
if (init_type == INIT_SEQ) {
if( FIAL_seq_in(val->seq, &tmp) < 0) {
return -1;
}
} else {
if(FIAL_set_symbol(val->map, iter->sym,
&tmp, env->interp) < 0) {
return -1;
}
}
break;
case AST_INIT_MOVE_ID:
if (init_type == INIT_SEQ) {
res = get_ref_from_sym_block_stack(&tmp, iter->sym,
env->block_stack);
if(res != 0) {
return -3;
}
if(FIAL_seq_in(val->seq, tmp.ref) < 0) {
return -1;
}
} else {
res = get_ref_from_sym_block_stack
(&tmp, iter->left->sym, env->block_stack);
if(res != 0) {
return -3;
}
if(FIAL_set_symbol(val->map, iter->sym,
tmp.ref, env->interp) < 0) {
return -1;
}
}
*tmp.ref = none;
break;
case AST_INIT_COPY_ID:
if (init_type == INIT_SEQ) {
res = get_ref_from_sym_block_stack
(&tmp, iter->sym, env->block_stack);
if (res != 0) {
return -3;
}
tmp2 = none;
if (FIAL_copy_value(&tmp2, tmp.ref, env->interp) < 0) {
return -1;
}
if (FIAL_seq_in(val->seq, &tmp2) < 0) {
FIAL_clear_value(&tmp2, env->interp);
return -1;
}
} else {
res = get_ref_from_sym_block_stack
(&tmp, iter->left->sym, env->block_stack);
if (res != 0) {
return -3;
}
tmp2 = none;
if (FIAL_copy_value(&tmp2, tmp.ref, env->interp) < 0) {
return -1;
}
if (FIAL_set_symbol(val->map, iter->sym,
&tmp2, env->interp) < 0) {
FIAL_clear_value(&tmp2, env->interp);
return -1;
}
}
break;
case AST_INIT_MOVE_ACS:
res = get_ref_from_map_access(&tmp, iter->left,
env->block_stack);
if (res != 0)
return -4;
if (init_type == INIT_SEQ) {
if( FIAL_seq_in(val->seq, tmp.ref) < 0) {
return -1;
}
} else {
if(FIAL_set_symbol(val->map, iter->sym,
tmp.ref, env->interp) < 0) {
return -1;
}
}
*tmp.ref = none;
break;
case AST_INIT_COPY_ACS:
res = get_ref_from_map_access(&tmp, iter->left,
env->block_stack);
if (res != 0)
return -4;
tmp2 = none;
if( FIAL_copy_value(&tmp2, tmp.ref, env->interp) < 0)
return -1;
if (init_type == INIT_SEQ) {
if( FIAL_seq_in(val->seq, &tmp2) < 0) {
FIAL_clear_value(&tmp2, env->interp);
return -1;
}
} else {
if(FIAL_set_symbol(val->map, iter->sym,
&tmp2, env->interp)<0) {
FIAL_clear_value(&tmp2, env->interp);
return -1;
}
}
break;
default:
assert(0);
break;
}
}
return 0;
}
static int insert_args (node *arglist_to, node *arglist_from,
struct FIAL_symbol_map *map_to, block *block_stack,
exec_env *env)
{
node *iter1, *iter2;
value val, ref, none;
int res;
memset(&none, 0, sizeof(val));
iter1 = arglist_to;
iter2 = arglist_from->left;
for(; iter1 != NULL; iter1=iter1->right) {
if(iter2) {
res = 0;
val = ref = none;
switch(iter2->type) {
case AST_ARGLIST_ID:
res = get_ref_from_sym_block_stack
(&ref, iter2->sym, block_stack);
if(res == 1) {
return -2;
}
res = set_symbol(map_to, iter1->sym, &ref,
env->interp);
if(res == -1) {
return -1;
}
break;
case AST_ARGLIST_EXPR:
assert(iter2->type == AST_ARGLIST_EXPR);
if(eval_expression(&val, iter2->left,env) < 0) {
return -3;
}
res = set_symbol(map_to, iter1->sym, &val,
env->interp);
if (res == -1)
return -1;
break;
case AST_ARGLIST_INIT:
if(handle_initializer(&val, iter2->left,
env) < 0) {
return -4;
}
res = set_symbol(map_to, iter1->sym, &val,
env->interp);
if(res == -1)
return -1;
break;
case AST_ARGLIST_MOVE_ID:
res = get_ref_from_sym_block_stack(&ref,
iter2->sym, block_stack);
if(res == 1) {
return -2;
}
val = *ref.ref;
res = set_symbol(map_to, iter1->sym, &val,
env->interp);
if(res == -1) {
return -1;
}
memset(ref.ref, 0, sizeof(*ref.ref));
break;
case AST_ARGLIST_COPY_ID:
res = get_ref_from_sym_block_stack(&ref,
iter2->sym, block_stack);
if(res == 1) {
return -2;
}
FIAL_copy_value (&val, ref.ref, env->interp);
res = set_symbol(map_to, iter1->sym, &val,
env->interp);
if(res == -1) {
FIAL_clear_value(&val, env->interp);
return -1;
}
break;
case AST_ARGLIST_MOVE_ACS:
assert(iter2->left);
res = get_ref_from_map_access(&ref, iter2->left,
env->block_stack);
if (res != 0)
return -5;
res = set_symbol(map_to, iter1->sym,
ref.ref, env->interp);
if(res < 0)
return -1;
*ref.ref = none;
break;
case AST_ARGLIST_COPY_ACS:
assert(iter2->left);
res = get_ref_from_map_access(&ref, iter2->left,
env->block_stack);
if(res != 0)
return -5;
if( FIAL_copy_value(&val, ref.ref, env->interp) < 0)
return -1;
if(set_symbol(map_to, iter1->sym, &val,
env->interp)
< 0) {
return -1;
}
break;
default:
assert(0);
}
iter2 = iter2->right;
} else {
int res;
assert(!iter2);
res = set_symbol(map_to, iter1->sym, &none,
env->interp);
if(res == -1) {
return -1;
}
}
}
return 0;
}
static inline int generate_external_arglist (int *argc,
struct FIAL_value ***argvp,
node *arglist,
struct FIAL_value **arguments,
exec_env *env)
{
/*FIXME: make it so the parser counts how many arguments there
* are.*/
int result = 0;
int count = 0;
node *iter;
int i, res;
int tmp;
value ref;
value *arg_strip = NULL;
(*argvp) = NULL;
/*
for(count = 0, iter = arglist; iter != NULL; iter = iter->right)
count++;
*argc = count; */
if(arglist) {
assert(arglist->n);
*argc = count = arglist->n;
arglist = arglist->left;
arg_strip = calloc(sizeof(*arg_strip), count);
*arguments = arg_strip;
}
if(count) {
(*argvp) = malloc(sizeof(struct FIAL_value *) * count);
/* no need to initialize.... */
if(!(*argvp)) {
result = -1;
goto error;
}
for(i = 0, iter = arglist; i < count; i++, iter = iter->right) {
value val;
memset(&val, 0, sizeof(val));
assert(iter);
switch(iter->type) {
case AST_ARGLIST_ID:
assert(iter->sym);
tmp = get_ref_from_sym_block_stack(&val,
iter->sym, env->block_stack);
if(tmp == 1) {
result = -2;
goto error;
}
assert(val.type == VALUE_REF);
(*argvp)[i] = val.ref;
break;
case AST_ARGLIST_EXPR:
assert(iter->type == AST_ARGLIST_EXPR);
assert(arg_strip);
tmp = eval_expression(arg_strip + i, iter->left,
env);
if(tmp < 0) {
result = -3;
goto error;
}
(*argvp)[i] = arg_strip + i;
break;
case AST_ARGLIST_INIT:
assert(iter->type == AST_ARGLIST_INIT);
assert(arg_strip);
tmp = handle_initializer(arg_strip + i,
iter->left, env);
if(tmp < 0) {
result = -4;
goto error;
}
(*argvp)[i] = arg_strip + i;
break;
case AST_ARGLIST_MOVE_ID:
assert(arg_strip);
res = get_ref_from_sym_block_stack(&ref,
iter->sym, env->block_stack);
if(res == 1) {
result = -2;
goto error;
}
FIAL_move_value(arg_strip + i, ref.ref,
env->interp);
(*argvp)[i] = arg_strip + i;
break;
case AST_ARGLIST_COPY_ID:
assert(arg_strip);
res = get_ref_from_sym_block_stack(&ref,
iter->sym, env->block_stack);
if(res == 1) {
result = -2;
goto error;
}
if(FIAL_copy_value(arg_strip + i, ref.ref,
env->interp) < 0) {
result = -1;
goto error;
}
(*argvp)[i] = arg_strip + i;
break;
case AST_ARGLIST_MOVE_ACS:
assert(iter->left);
assert(arg_strip);
res = get_ref_from_map_access(&ref,
iter->left, env->block_stack);
if(res != 0) {
result = -5;
goto error;
}
FIAL_move_value(arg_strip + i, ref.ref,
env->interp);
(*argvp)[i] = arg_strip + i;
break;
case AST_ARGLIST_COPY_ACS:
assert(iter->left);
assert(arg_strip);
res = get_ref_from_map_access(&ref,
iter->left, env->block_stack);
if(res != 0) {
result = -5;
goto error;
}
if(FIAL_copy_value(arg_strip + i, ref.ref,
env->interp) < 0) {
result = -1;
goto error;
}
(*argvp)[i] = arg_strip + i;
break;
default:
assert(0);
break;
}
}
return 0;
}
return 1; /* no args... not sure if this matters. */
error:
free(*argvp);
/* freeing is fine, since expressable values do not have
* finilizers. */
free_arg_strip(count, arg_strip, env->interp );
*argvp = NULL;
*arguments = NULL;
return result;
}
object *bs_eval(object *exp, object *env)
{
tailcall:
if (is_empty_list(exp)) {
error("unable to evaluate empty list");
} else if (is_self_evaluating(exp)) {
return exp;
} else if (is_variable(exp)) {
return lookup_variable_value(exp, env);
} else if (is_quoted(exp)) {
return quoted_expression(exp);
} else if (is_assignment(exp)) {
return eval_assignment(exp, env);
} else if (is_definition(exp)) {
return eval_definition(exp, env);
} else if (is_if(exp)) {
if (is_true(bs_eval(if_predicate(exp), env))) {
exp = if_consequent(exp);
} else {
exp = if_alternate(exp);
}
goto tailcall;
} else if (is_lambda(exp)) {
return make_compound_proc(lambda_parameters(exp),
lambda_body(exp),
env);
} else if (is_begin(exp)) {
exp = begin_actions(exp);
if (is_empty_list(exp)) {
error("empty begin block");
}
while (!is_empty_list(cdr(exp))) {
bs_eval(car(exp), env);
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_cond(exp)) {
exp = cond_to_if(exp);
goto tailcall;
} else if (is_let(exp)) {
exp = let_to_application(exp);
goto tailcall;
} else if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(1);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_false(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(0);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_true(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_application(exp)) {
object *procedure = bs_eval(application_operator(exp), env);
object *parameters = eval_parameters(application_operands(exp), env);
// handle eval specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == eval_proc) {
exp = eval_expression(parameters);
env = eval_environment(parameters);
goto tailcall;
}
// handle apply specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == apply_proc) {
procedure = apply_operator(parameters);
parameters = apply_operands(parameters);
}
if (is_primitive_proc(procedure)) {
return (procedure->value.primitive_proc)(parameters);
} else if (is_compound_proc(procedure)) {
env = extend_environment(
procedure->value.compound_proc.parameters,
parameters,
procedure->value.compound_proc.env);
exp = make_begin(procedure->value.compound_proc.body);
goto tailcall;
} else {
error("unable to apply unknown procedure type");
}
} else {
error("unable to evaluate expression");
}
}
static int handle_assign_right (struct FIAL_value *val,
struct FIAL_ast_node *node,
struct FIAL_exec_env *env)
{
struct FIAL_value ref;
int res;
switch (node->type) {
case AST_SEQ_INITIALIZER: /* fallthrough */
case AST_MAP_INITIALIZER:
if( handle_initializer(val, node, env) < 0)
return -1;
break;
case AST_INIT_MOVE_ID:
res = get_ref_from_sym_block_stack(&ref, node->sym,
env->block_stack);
if (res != 0) {
env->error.code = ERROR_UNDECLARED_VAR;
env->error.static_msg =
"unknown variable in move assignmnet";
FIAL_set_error(env);
return -1;
}
FIAL_move_value(val, ref.ref, env->interp);
break;
case AST_INIT_COPY_ID:
res = get_ref_from_sym_block_stack(&ref, node->sym,
env->block_stack);
if (res != 0) {
env->error.code = ERROR_UNDECLARED_VAR;
env->error.static_msg =
"unknown variable in copy assignmnet";
FIAL_set_error(env);
return -1;
}
FIAL_copy_value(val, ref.ref, env->interp);
break;
case AST_INIT_MOVE_ACS:
res = get_ref_from_map_access(&ref, node->left,
env->block_stack);
if (res != 0) {
env->error.code = ERROR_INVALID_MAP_ACCESS;
env->error.static_msg =
"bad map access in move assignment";
FIAL_set_error(env);
return -1;
}
FIAL_move_value (val, ref.ref, env->interp);
break;
case AST_INIT_COPY_ACS:
res = get_ref_from_map_access(&ref, node->left,
env->block_stack);
if (res != 0) {
env->error.code = ERROR_INVALID_MAP_ACCESS;
env->error.static_msg =
"bad map access in copy assignment";
FIAL_set_error(env);
return -1;
}
FIAL_copy_value (val, ref.ref, env->interp);
break;
default:
if (eval_expression(val, node, env) < 0)
return -1;
break;
}
return 0;
}
/*
* define_var
*
* define a new var with reading its def from input file
* (starts parsing after ":", so ":" has to be read before)
*
* params: varname..name of new var
* varlist..list new var should be inserted at the beginning
* inpf.....input file where to read def from
* flag.....flags: VF_ONLYONCE to avoid re-definition of a var
* result: ptr to new var
*
* definition syntax in input file:
* <vartype>[/flag]["="<deftext value>]
* legal vartypes: see VT_STR_xx in "vars.h"
* legal flags : see VF_STR_xx in "vars.h"
*/
HSCATTR *define_var(HSCPRC * hp, DLLIST * varlist, ULONG unmasked_flags)
{
HSCATTR *var = NULL; /* result */
BOOL ok = FALSE;
BYTE val_vartype = VT_NONE; /* var-type (numeric) */
BOOL newattr = FALSE; /* next word read from input */
STRPTR nw = NULL;
STRPTR varname = NULL;
BOOL eof_called = FALSE; /* used at end-of-func, if nw==NULL */
INFILE *inpf = hp->inpf;
/* read attribute name */
nw = infget_attrid(hp);
if (nw)
varname = strclone(nw); /* remember attribute name */
else
eof_called = TRUE; /* err_eof() called already */
/* read attribute type */
if (nw) {
if (parse_wd(hp, ":")) {
nw = infgetw(inpf);
if (nw)
val_vartype = str2vartype(nw);
} else
inungetcw(inpf);
}
if (nw) {
/*
* look if attr already exist;
* if yes, clear old attribute
* to redefine the new one
*/
var = find_varname(varlist, varname);
if (var) {
DLNODE *nd = find_attrnode(varlist, varname);
/* remove old attribute */
if (nd)
del_dlnode(varlist, nd);
else
panic("no node for redefined attribute");
hsc_message(hp, MSG_ATTR_REDEFINED,
"redefined %a", varname);
}
/*
* create new attribute
*/
DDA(fprintf(stderr, DHL "new attr: %s\n", varname));
var = app_var(varlist, varname);
/* set type */
var->vartype = val_vartype;
if (var->vartype == VT_ENUM) {
/* init enum-attribute */
read_enum_str(hp, var);
} else if (var->vartype == VT_BOOL) {
/* init boolean attr with FALSE */
set_varbool(var, FALSE);
}
newattr = TRUE;
}
/* disable "/STRIPEXT" and "/GETSIZE" for non-URI-attributes */
if (nw) {
if (var->vartype != VT_URI)
unmasked_flags |= VF_GETSIZE | VF_STRIPEXT;
nw = infgetw(inpf); /* get net word */
}
/*
* handle attribute flags
*/
while (nw && !strcmp(nw, "/")) {
nw = infgetw(inpf); /* read flag identifier */
if (nw) {
BOOL ok = FALSE;
ok |= check_attr_option(hp, nw, var,
VF_CONST_STR, VF_CONST_SHT,
VF_CONST, unmasked_flags);
ok |= check_attr_option(hp, nw, var,
VF_GLOBAL_STR, VF_GLOBAL_SHT,
VF_GLOBAL, unmasked_flags);
ok |= check_attr_option(hp, nw, var,
VF_JERK_STR, VF_JERK_SHT,
VF_JERK, unmasked_flags);
ok |= check_attr_option(hp, nw, var,
VF_ONLYONCE_STR, VF_ONLYONCE_SHT,
VF_ONLYONCE, unmasked_flags);
ok |= check_attr_option(hp, nw, var,
VF_REQUIRED_STR, VF_REQUIRED_SHT,
VF_REQUIRED, unmasked_flags);
ok |= check_attr_option(hp, nw, var,
VF_GETSIZE_STR, VF_GETSIZE_SHT,
VF_GETSIZE, unmasked_flags);
ok |= check_attr_option(hp, nw, var,
VF_STRIPEXT_STR, VF_STRIPEXT_SHT,
VF_STRIPEXT, unmasked_flags);
ok |= check_attr_option(hp, nw, var,
VF_OBSOLETE_STR, VF_OBSOLETE_SHT,
VF_OBSOLETE, unmasked_flags);
ok |= check_attr_option(hp, nw, var,
VF_RECOMMENDED_STR, VF_RECOMMENDED_SHT,
VF_RECOMMENDED, unmasked_flags);
if (!ok) {
hsc_message(hp, MSG_UNKN_ATTR_OPTION,
"unknown attribute flag %q", nw);
}
/* read next word (should be "/", "=" or next attr / ">") */
nw = infgetw(inpf);
} else
hsc_msg_eof(hp, "defining attribute");
}
/*
* handle default value
*/
if (nw && !strcmp(nw, "=")) {
/* get new deftext value */
STRPTR new_deftext = NULL;
LONG old_attrflag = var->varflag;
/* disable quotemode-checking */
var->varflag |= VF_KEEP_QUOTES;
if (!(var->deftext))
new_deftext = eval_expression(hp, var, NULL);
else {
STRPTR dummy;
hsc_message(hp, MSG_SYMB_2ND_DEFAULT,
"default value for %A already set", var);
/* skip illegal default value */
dummy = eval_expression(hp, var, NULL);
}
/* restore quotemode-checking */
var->varflag = old_attrflag;
/* store default text value */
if (new_deftext)
var->deftext = strclone(new_deftext);
/* read next word, only to be ungotten below */
nw = infgetw(inpf);
}
/* check for unexpected end of file */
if (!nw) {
if (!eof_called)
hsc_msg_eof(hp, "defining attribute");
} else {
/* end of var definition reached */
inungetcw(inpf);
ok = TRUE;
}
/* cleanup */
if (!ok && var) {
DLNODE *nd = find_attrnode(varlist, varname);
if (nd)
del_dlnode(varlist, (APTR) nd);
else
del_hscattr(var);
var = NULL;
}
ufreestr(varname);
return (var);
}
static void exec_printstatement(const struct PrintStatement* statement, struct Scope* scope)
{
printf("%g\n", eval_expression(statement->expression, scope));
}
void
shell (func_t * scope)
{
/**
* shell - when FACT is run by default it comes to here. The
* main user interface for FACT, this function grabs an
* expression of input, parses it, runs it, and repeats. It
* will continue to do so until the user does a C-d, C-c,
* returns a value from the main scope, or calls the exit
* function.
*
* @scope - the scope to use when evaluating expressions.
*/
FACT_t returned; // The value returned by the interpreter.
unsigned int end_line; // ...
unsigned int hold_line; // ...
int *newlines;
char *input;
char *hold_input; // Used in the main loop to check for else clauses.
char **tokenized; // input, tokenized.
char **hold_tokens; // Also used to check for else clauses.
/* Before we start, print out the copyright info, logo and
* a guide to some helpful functions.
*/
print_logo ();
printf ("The FACT programming language interactive shell\n"
"© 2010, 2011 Matthew Plant, under the GPL version 3.\n");
hold_input = NULL;
scope->file_name = "stdin";
scope->line = 1;
end_line = 0;
for (;;) // Heh, that looks like a spider.
{
/* Set the line number to end_line, in case we missed any while evaluating
* the last expression.
*/
scope->line += end_line;
end_line = 0;
// Then, get raw input for an entire expression.
if (hold_input == NULL)
input = get_input (stdin, &end_line, "S>", "C>");
else
{
input = hold_input;
hold_input = NULL;
}
/* We do two checks for EOF signals: once before tokenizing, and once after.
* I am not completely sure as to why this is the case, but I do remember at
* some point it didn't exit so I added the second check.
*/
if (input == NULL)
break;
// Tokenize the input.
tokenized = get_words (input);
if (tokenized == NULL)
break;
/* If the first token in the expression is if/on_error, continue to get input
* as long as the first token is else. I could forsee this being an issue in
* places where the else is placed erroneosly, but that'll be fixed later I
* assume.
*/
if ((tokenized[0][0] == '\n'
&& (!tokcmp (tokenized[1], "if")
|| !tokcmp (tokenized[1], "error")))
|| (!tokcmp (tokenized[0], "if")
|| !tokcmp (tokenized[0], "error")))
{
for (;;)
{
/* Go through all the steps we went through from the start of the loop
* down to here.
*/
hold_input = get_input (stdin, &end_line, "?>", "C>");
if (hold_input == NULL|| (hold_tokens = get_words (hold_input)) == NULL)
break;
// Check to see if the statement starts with else.
if ((hold_tokens[0][0] == '\n'
&& !tokcmp (hold_tokens[1], "else"))
|| !tokcmp (hold_tokens[0], "else"))
{
input[strlen (input) - 1] = '\0';
input = combine_strs (input, hold_input);
hold_input = NULL;
}
else
break;
}
printf ("\n");
tokenized = get_words (input);
}
// Get the newlines and parse the string.
tokenized = parse (tokenized, "stdin", scope->line, &newlines);
if (tokenized == NULL)
continue;
// Reset the instruction pointer.
reset_ip ();
// Evaluate the expression.
returned = eval_expression (scope, make_syn_tree (tokenized, newlines));
/* If there were errors, print them out. Otherwise,
* print the value of the variable or the name of
* the function returned.
*/
if (returned.type == ERROR_TYPE)
errorman_dump (returned.error);
else if (returned.type == VAR_TYPE)
printf ("Returned value: %s\n", mpc_get_str (returned.v_point->data));
else
printf ("Returned object [%s]\n", returned.f_point->name);
/* Check to see if the value is to be returned, and
* if so, exit.
*/
if (returned.return_signal)
break;
}
puts ("\nExiting...");
}
int parse_db(struct _asm_context *asm_context, int null_term_flag)
{
char token[TOKENLEN];
int token_type;
int data32;
if (asm_context->segment==SEGMENT_BSS)
{
printf("Error: .bss segment doesn't support initialized data at %s:%d\n", asm_context->filename, asm_context->line);
return -1;
}
while(1)
{
token_type=get_token(asm_context, token, TOKENLEN);
if (token_type==TOKEN_EOL || token_type==TOKEN_EOF) break;
if (token_type==TOKEN_QUOTED)
{
unsigned char *s=(unsigned char *)token;
while(*s!=0)
{
if (*s=='\\')
{
int e=escape_char(asm_context, s);
if (e==0)
{
return -1;
}
s=s+e;
}
memory_write_inc(asm_context, *s, DL_DATA);
asm_context->data_count++;
s++;
}
if (null_term_flag==1)
{
memory_write_inc(asm_context, 0, DL_DATA);
asm_context->data_count++;
}
}
else
{
pushback(asm_context, token, token_type);
if (eval_expression(asm_context, &data32)==-1)
{
eat_operand(asm_context);
}
memory_write_inc(asm_context, (unsigned char)data32, DL_DATA);
asm_context->data_count++;
}
token_type=get_token(asm_context, token, TOKENLEN);
if (token_type==TOKEN_EOL || token_type==TOKEN_EOF) break;
if (IS_NOT_TOKEN(token,','))
{
printf("Parse error: expecting a ',' on line %d.\n", asm_context->line);
return -1;
}
}
asm_context->line++;
return 0;
}
int parse_instruction_mips(struct _asm_context *asm_context, char *instr)
{
struct _operand operands[3];
int operand_count = 0;
char token[TOKENLEN];
int token_type;
char instr_case[TOKENLEN];
int paren_flag;
int num,n,r;
int opcode;
#if 0
int n,cond,s=0;
int opcode=0;
#endif
lower_copy(instr_case, instr);
memset(operands, 0, sizeof(operands));
//printf("%s %s\n", instr_case, instr);
while(1)
{
token_type = tokens_get(asm_context, token, TOKENLEN);
if (token_type == TOKEN_EOL) { break; }
//printf("token=%s token_type=%d\n", token, token_type);
if (operand_count == 0 && IS_TOKEN(token,'.'))
{
strcat(instr_case, ".");
strcat(instr, ".");
token_type = tokens_get(asm_context, token, TOKENLEN);
strcat(instr, token);
n = 0;
while(token[n] != 0) { token[n]=tolower(token[n]); n++; }
strcat(instr_case, token);
continue;
}
do
{
paren_flag = 0;
if (IS_TOKEN(token,'('))
{
token_type = tokens_get(asm_context, token, TOKENLEN);
paren_flag = 1;
}
num = get_register_mips(token, 't');
if (num != -1)
{
operands[operand_count].value = num;
operands[operand_count].type = OPERAND_TREG;
if (paren_flag == 0) { break; }
}
else
if (paren_flag == 0)
{
num = get_register_mips(token, 'f');
if (num != -1)
{
operands[operand_count].value = num;
operands[operand_count].type = OPERAND_FREG;
break;
}
}
if (paren_flag == 1)
{
token_type = tokens_get(asm_context, token, TOKENLEN);
if (IS_NOT_TOKEN(token,')'))
{
print_error_unexp(token, asm_context);
return -1;
}
operands[operand_count].reg2 = operands[operand_count].value;
operands[operand_count].value = 0;
operands[operand_count].type = OPERAND_IMMEDIATE_RS;;
break;
}
operands[operand_count].type = OPERAND_IMMEDIATE;
if (asm_context->pass == 1)
{
eat_operand(asm_context);
break;
}
tokens_push(asm_context, token, token_type);
if (eval_expression(asm_context, &num) != 0)
{
print_error_unexp(token, asm_context);
return -1;
}
operands[operand_count].value = num;
token_type = tokens_get(asm_context, token, TOKENLEN);
if (IS_TOKEN(token,'('))
{
token_type = tokens_get(asm_context, token, TOKENLEN);
num = get_register_mips(token, 't');
if (num == -1)
{
print_error_unexp(token, asm_context);
return -1;
}
operands[operand_count].reg2 = num;
operands[operand_count].type = OPERAND_IMMEDIATE_RS;;
token_type = tokens_get(asm_context, token, TOKENLEN);
if (IS_NOT_TOKEN(token,')'))
{
print_error_unexp(token, asm_context);
return -1;
}
}
else
{
tokens_push(asm_context, token, token_type);
}
} while(0);
operand_count++;
token_type = tokens_get(asm_context, token, TOKENLEN);
if (token_type == TOKEN_EOL) { break; }
if (IS_NOT_TOKEN(token,','))
{
print_error_unexp(token, asm_context);
return -1;
}
if (operand_count == 3)
{
print_error_unexp(token, asm_context);
return -1;
}
}
if (asm_context->pass == 1)
{
add_bin32(asm_context, 0, IS_OPCODE);
return 4;
}
// Check pseudo-instructions
if (strcmp(instr_case, "move") == 0 && operand_count == 2)
{
strcpy(instr_case, "add");
operands[operand_count].value = 0;
operands[operand_count].type = OPERAND_TREG;;
operand_count++;
}
else
#if 0
if (strcmp(instr_case, "li") == 0 && operand_count == 2)
{
strcpy(instr_case, "addi");
memcpy(&operands[operand_count], &operands[operand_count-1], sizeof(struct _operand));
operands[operand_count-1].value = 0;
operands[operand_count-1].reg2 = 0;
operands[operand_count-1].type = OPERAND_TREG;;
operand_count++;
}
else
#endif
if (strcmp(instr_case, "nop") == 0 && operand_count == 0)
{
strcpy(instr_case, "add");
operand_count = 3;
}
else
if (strcmp(instr_case, "neg") == 0 && operand_count == 1)
{
strcpy(instr_case, "subu");
memcpy(&operands[1], &operands[0], sizeof(struct _operand));
operand_count = 3;
}
// R-Type Instruction [ op 6, rs 5, rt 5, rd 5, sa 5, function 6 ]
n = 0;
while(mips_r_table[n].instr != NULL)
{
if (strcmp(instr_case, mips_r_table[n].instr) == 0)
{
char shift_table[] = { 0, 11, 21, 16, 6 };
if (mips_r_table[n].operand_count != operand_count)
{
print_error_illegal_operands(instr, asm_context);
return -1;
}
opcode = mips_r_table[n].function;
for (r = 0; r < operand_count; r++)
{
if (operands[r].type != OPERAND_TREG)
{
//printf("%s %s %s\n", instr_case, mips_r_table[n].instr, instr);
printf("Error: '%s' expects registers at %s:%d\n", instr, asm_context->filename, asm_context->line);
return -1;
}
//printf("%s %d<<%d\n", instr, operands[r].value, shift_table[(int)mips_r_table[n].operand[r]]);
opcode |= operands[r].value << shift_table[(int)mips_r_table[n].operand[r]];
}
add_bin32(asm_context, opcode, IS_OPCODE);
return 4;
}
n++;
}
// J-Type Instruction [ op 6, target 26 ]
if (strcmp(instr_case, "ja") == 0 || strcmp(instr_case, "jal") == 0)
{
// FIXME - what to do with this
//unsigned int upper = (address + 4) & 0xf0000000;
if (operand_count != 1)
{
print_error_illegal_operands(instr, asm_context);
return -1;
}
if (operands[0].type != OPERAND_IMMEDIATE)
{
printf("Error: Expecting address for '%s' at %s:%d\n", instr, asm_context->filename, asm_context->line);
return -1;
}
if (instr_case[2] == 'l') { opcode = 2 << 26; }
else { opcode = 3 << 26; }
add_bin32(asm_context, opcode | operands[0].value >> 2, IS_OPCODE);
return 4;
}
// Coprocessor Instruction [ op 6, format 5, ft 5, fs 5, fd 5, funct 6 ]
n = 0;
while(mips_cop_table[n].instr != NULL)
{
if (strcmp(instr_case, mips_cop_table[n].instr) == 0)
{
char shift_table[] = { 0, 5, 11, 16 };
if (mips_cop_table[n].operand_count != operand_count)
{
print_error_illegal_operands(instr, asm_context);
return -1;
}
opcode = (0x11 << 26) | (mips_cop_table[n].format << 21) | mips_cop_table[n].function;
for (r = 0; r < operand_count; r++)
{
if (operands[r].type != OPERAND_FREG)
{
printf("Error: '%s' expects registers at %s:%d\n", instr, asm_context->filename, asm_context->line);
return -1;
}
opcode |= operands[r].value << shift_table[(int)mips_cop_table[n].operand[r]];
}
add_bin32(asm_context, opcode, IS_OPCODE);
return 4;
}
n++;
}
// I-Type? [ op 6, rs 5, rt 5, imm 16 ]
n = 0;
while(mips_i_table[n].instr != NULL)
{
if (strcmp(instr_case, mips_i_table[n].instr) == 0)
{
char shift_table[] = { 0, 0, 21, 16 };
if (mips_i_table[n].operand_count != operand_count)
{
print_error_opcount(instr, asm_context);
return -1;
}
opcode = mips_i_table[n].function << 26;
for (r = 0; r < mips_i_table[n].operand_count; r++)
{
if ((mips_i_table[n].operand[r] == MIPS_OP_RT ||
mips_i_table[n].operand[r] == MIPS_OP_RS) &&
operands[r].type == OPERAND_TREG)
{
opcode |= operands[r].value << shift_table[(int)mips_i_table[n].operand[r]];
}
else
if (mips_i_table[n].operand[r] == MIPS_OP_LABEL)
{
// FIXME - Calculate address
//if (operands[r].value > 65535 || operands[r].value < -32768)
//{
// print_error("Constant larger than 16 bit.", asm_context);
// return -1;
//}
opcode |= operands[r].value;
}
else
if (mips_i_table[n].operand[r] == MIPS_OP_IMMEDIATE)
{
if (operands[r].value > 65535 || operands[r].value < -32768)
{
print_error("Constant larger than 16 bit.", asm_context);
return -1;
}
opcode |= operands[r].value;
}
else
if (mips_i_table[n].operand[r] == MIPS_OP_IMMEDIATE_RS)
{
if (operands[r].value > 65535 || operands[r].value < -32768)
{
print_error("Constant larger than 16 bit.", asm_context);
return -1;
}
opcode |= operands[r].value;
opcode |= operands[r].reg2 << 21;
}
else
if (mips_i_table[n].operand[r] == MIPS_OP_RT_IS_0)
{
// Derr
}
else
if (mips_i_table[n].operand[r] == MIPS_OP_RT_IS_1)
{
opcode |= 1 << 16;
}
else
{
print_error_illegal_operands(instr, asm_context);
return -1;
}
opcode |= operands[r].value << shift_table[(int)mips_i_table[n].operand[r]];
}
add_bin32(asm_context, opcode, IS_OPCODE);
return 4;
}
n++;
}
print_error_unknown_instr(instr, asm_context);
return -1;
}
double eval_expression(Node* root) {
switch (root->type) {
case AFFECTATION:
set_var(root->children[0]->var, root->children[1]);
return eval_expression(root->children[0]);
case NOMBRE:
return root->val;
case VARIABLE:
return root->var->value;
case PLUS:
return eval_expression(root->children[0]) + eval_expression(root->children[1]);
case MOINS:
return eval_expression(root->children[0]) - eval_expression(root->children[1]);
case MULT:
return eval_expression(root->children[0]) * eval_expression(root->children[1]);
case DIVISION:
return eval_expression(root->children[0]) / eval_expression(root->children[1]);
case SUPERIOR:
return (eval_expression(root->children[0]) > eval_expression(root->children[1]));
case INFERIOR:
return (eval_expression(root->children[0]) < eval_expression(root->children[1]));
case EQUAL:
return (eval_expression(root->children[0]) == eval_expression(root->children[1]));
case DIFFERENT:
return (eval_expression(root->children[0]) != eval_expression(root->children[1]));
case SUPERIOR_EQUAL:
return (eval_expression(root->children[0]) >= eval_expression(root->children[1]));
case INFERIOR_EQUAL:
return (eval_expression(root->children[0]) <= eval_expression(root->children[1]));
default:
printf("Error: unknown expression type: %d\n", root->type);
break;
}
}
void set_var(Node_var* variable, Node* expression_src) {
variable->value = eval_expression(expression_src);
}
int parse_db(struct _asm_context *asm_context, int null_term_flag)
{
char token[TOKENLEN];
int token_type;
int data32;
if (asm_context->segment == SEGMENT_BSS)
{
printf("Error: .bss segment doesn't support initialized data at %s:%d\n", asm_context->filename, asm_context->line);
return -1;
}
while(1)
{
token_type = tokens_get(asm_context, token, TOKENLEN);
if (token_type == TOKEN_EOL || token_type == TOKEN_EOF) break;
if (token_type == TOKEN_QUOTED)
{
uint8_t *s = (uint8_t *)token;
while(*s != 0)
{
if (*s == '\\')
{
int e = tokens_escape_char(asm_context, s);
if (e == 0)
{
return -1;
}
s = s + e;
}
memory_write_inc(asm_context, *s, DL_DATA);
asm_context->data_count++;
s++;
}
if (null_term_flag == 1)
{
memory_write_inc(asm_context, 0, DL_DATA);
asm_context->data_count++;
}
}
else
{
tokens_push(asm_context, token, token_type);
if (eval_expression(asm_context, &data32) != 0)
{
if (asm_context->pass == 2)
{
return -1;
}
eat_operand(asm_context);
data32 = 0;
}
if (data32 < -128 || data32 > 0xff)
{
print_error_range("db", -128, 0xff, asm_context);
return -1;
}
memory_write_inc(asm_context, (uint8_t)data32, DL_DATA);
asm_context->data_count++;
}
token_type = tokens_get(asm_context, token, TOKENLEN);
if (token_type == TOKEN_EOL || token_type == TOKEN_EOF) { break; }
if (IS_NOT_TOKEN(token,','))
{
print_error_expecting(",", token, asm_context);
return -1;
}
}
asm_context->line++;
return 0;
}
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 */
}
object *eval(object *exp, object *env) {
object *procedure;
object *arguments;
object *result;
bool tailcall = false;
do {
if (is_self_evaluating(exp))
return exp;
if (is_variable(exp))
return lookup_variable_value(exp, env);
if (is_quoted(exp))
return text_of_quotation(exp);
if (is_assignment(exp))
return eval_assignment(exp, env);
if (is_definition(exp))
return eval_definition(exp, env);
if (is_if(exp)) {
exp = is_true(eval(if_predicate(exp), env)) ? if_consequent(exp) : if_alternative(exp);
tailcall = true;
continue;
}
if (is_lambda(exp))
return make_compound_proc(lambda_parameters(exp), lambda_body(exp), env);
if (is_begin(exp)) {
exp = begin_actions(exp);
while (!is_last_exp(exp)) {
eval(first_exp(exp), env);
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_cond(exp)) {
exp = cond_to_if(exp);
tailcall = true;
continue;
}
if (is_let(exp)) {
exp = let_to_application(exp);
tailcall = true;
continue;
}
if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty(exp))
return make_boolean(true);
while (!is_last_exp(exp)) {
result = eval(first_exp(exp), env);
if (is_false(result))
return result;
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty(exp)) {
return make_boolean(false);
}
while (!is_last_exp(exp)) {
result = eval(first_exp(exp), env);
if (is_true(result))
return result;
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_application(exp)) {
procedure = eval(operator(exp), env);
arguments = list_of_values(operands(exp), env);
if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == eval_proc) {
exp = eval_expression(arguments);
env = eval_environment(arguments);
tailcall = true;
continue;
}
if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == apply_proc) {
procedure = apply_operator(arguments);
arguments = apply_operands(arguments);
}
if (is_primitive_proc(procedure))
return (procedure->data.primitive_proc.fn)(arguments);
if (is_compound_proc(procedure)) {
env = extend_environment(procedure->data.compound_proc.parameters, arguments, procedure->data.compound_proc.env);
exp = make_begin(procedure->data.compound_proc.body);
tailcall = true;
continue;
}
return make_error(342, "unknown procedure type");
} // is_application()
} while (tailcall);
fprintf(stderr, "cannot eval unknown expression type\n");
exit(EXIT_FAILURE);
}
ast_t* eval_call(env_t* env, ast_t* ast) {
ast_t* func = NULL;
ast_t* result = NULL;
char* fn = NULL; /* function name */
switch(ast->data.call.call_type) {
case ct_anonymous:
fn = "<anonymous>";
func = ast->data.call.function.function;
break;
case ct_named:
fn = ast->data.call.function.id;
func = get_ast_by_id(env, fn);
if(func == NULL) {
error_id(NULL, fn);
};
break;
}
switch(func->type) {
case at_function:{
size_t i;
if(ast->data.call.callargs->data.callargs.count != func->data.function.params->data.params.count) {
error_paramcount(NULL, fn, func->data.function.params->data.params.count, ast->data.call.callargs->data.callargs.count);
}
env_t* inner = create_env();
inner->parent = env;
for(i = 0; i < func->data.function.params->data.params.count; i++) {
set_ast_to_id(
inner,
func->data.function.params->data.params.params[i],
eval_expression(env,ast->data.call.callargs->data.callargs.callargs[i])
);
}
/* execute the function */
exec_statements(inner, func->data.function.statements);
/* get the result */
inner->parent = NULL; /* must be NULL, get_ast_by_id() also searches the parent environment */
result = get_ast_by_id(inner, "@");
free_env(inner);
break;
}
case at_builtin:
if(ast->data.call.callargs->data.callargs.count != func->data.builtin.paramcount) {
error_paramcount(NULL, fn, func->data.function.params->data.params.count, ast->data.call.callargs->data.callargs.count);
}
switch(func->data.builtin.paramcount) {
case 0:
result = func->data.builtin.function.builtin_0();
break;
case 1: {
ast_t* p = eval_expression(env,ast->data.call.callargs->data.callargs.callargs[0]);
result = func->data.builtin.function.builtin_1(p);
dec_ref(p);
break;
}
case 2: {
ast_t* p1 = eval_expression(env,ast->data.call.callargs->data.callargs.callargs[0]);
ast_t* p2 = eval_expression(env,ast->data.call.callargs->data.callargs.callargs[1]);
result = func->data.builtin.function.builtin_2(p1,p2);
dec_ref(p1);
dec_ref(p2);
break;
}
case 3: {
ast_t* p1 = eval_expression(env, ast->data.call.callargs->data.callargs.callargs[0]);
ast_t* p2 = eval_expression(env, ast->data.call.callargs->data.callargs.callargs[1]);
ast_t* p3 = eval_expression(env, ast->data.call.callargs->data.callargs.callargs[2]);
result = func->data.builtin.function.builtin_3(p1,p2,p3);
dec_ref(p1);
dec_ref(p2);
dec_ref(p3);
break;
}
default:
printf("\n\n*** HINT TO DEVELOPER ***\nimplement builtincall in vm.c\n\n");
exit(1);
/* if you create a builtin function with more parameters then you have to add a case here */
break;
}
break;
default:
error_expected(NULL, get_ast_type_name(at_function), get_ast_type_name(func->type));
break;
}
return result;
}
struct t_gui_hotlist *
gui_hotlist_add (struct t_gui_buffer *buffer,
enum t_gui_hotlist_priority priority,
struct timeval *creation_time)
{
struct t_gui_hotlist *new_hotlist, *ptr_hotlist;
int i, count[GUI_HOTLIST_NUM_PRIORITIES], rc;
char *value, str_value[32];
if (!buffer || !gui_add_hotlist)
return NULL;
/* do not add core buffer if upgrading */
if (weechat_upgrading && (buffer == gui_buffer_search_main ()))
return NULL;
if (priority > GUI_HOTLIST_MAX)
priority = GUI_HOTLIST_MAX;
/* check if priority is OK according to buffer notify level value */
if (!gui_hotlist_check_buffer_notify (buffer, priority))
return NULL;
/* create hashtable if needed (to evaluate conditions) */
if (!gui_hotlist_hashtable_add_conditions_pointers)
{
gui_hotlist_hashtable_add_conditions_pointers = hashtable_new (
32,
WEECHAT_HASHTABLE_STRING,
WEECHAT_HASHTABLE_POINTER,
NULL,
NULL);
if (!gui_hotlist_hashtable_add_conditions_pointers)
return NULL;
}
if (!gui_hotlist_hashtable_add_conditions_vars)
{
gui_hotlist_hashtable_add_conditions_vars = hashtable_new (
32,
WEECHAT_HASHTABLE_STRING,
WEECHAT_HASHTABLE_STRING,
NULL,
NULL);
if (!gui_hotlist_hashtable_add_conditions_vars)
return NULL;
}
if (!gui_hotlist_hashtable_add_conditions_options)
{
gui_hotlist_hashtable_add_conditions_options = hashtable_new (
32,
WEECHAT_HASHTABLE_STRING,
WEECHAT_HASHTABLE_STRING,
NULL,
NULL);
if (!gui_hotlist_hashtable_add_conditions_options)
return NULL;
hashtable_set (gui_hotlist_hashtable_add_conditions_options,
"type", "condition");
}
/* set data in hashtables */
hashtable_set (gui_hotlist_hashtable_add_conditions_pointers,
"window", gui_current_window);
hashtable_set (gui_hotlist_hashtable_add_conditions_pointers,
"buffer", buffer);
snprintf (str_value, sizeof (str_value), "%d", priority);
hashtable_set (gui_hotlist_hashtable_add_conditions_vars,
"priority", str_value);
/* check if conditions are true */
value = eval_expression (CONFIG_STRING(config_look_hotlist_add_conditions),
gui_hotlist_hashtable_add_conditions_pointers,
gui_hotlist_hashtable_add_conditions_vars,
gui_hotlist_hashtable_add_conditions_options);
rc = (value && (strcmp (value, "1") == 0));
if (value)
free (value);
if (!rc)
return NULL;
/* init count */
for (i = 0; i < GUI_HOTLIST_NUM_PRIORITIES; i++)
{
count[i] = 0;
}
ptr_hotlist = gui_hotlist_search (gui_hotlist, buffer);
if (ptr_hotlist)
{
/* return if priority is greater or equal than the one to add */
if (ptr_hotlist->priority >= priority)
{
ptr_hotlist->count[priority]++;
gui_hotlist_changed_signal ();
return ptr_hotlist;
}
/*
* if buffer is present with lower priority: save counts, remove it
* and go on
*/
memcpy (count, ptr_hotlist->count, sizeof (ptr_hotlist->count));
gui_hotlist_free (&gui_hotlist, &last_gui_hotlist, ptr_hotlist);
}
new_hotlist = malloc (sizeof (*new_hotlist));
if (!new_hotlist)
return NULL;
new_hotlist->priority = priority;
if (creation_time)
{
memcpy (&(new_hotlist->creation_time),
creation_time, sizeof (*creation_time));
}
else
gettimeofday (&(new_hotlist->creation_time), NULL);
new_hotlist->buffer = buffer;
memcpy (new_hotlist->count, count, sizeof (new_hotlist->count));
new_hotlist->count[priority]++;
new_hotlist->next_hotlist = NULL;
new_hotlist->prev_hotlist = NULL;
gui_hotlist_add_hotlist (&gui_hotlist, &last_gui_hotlist, new_hotlist);
gui_hotlist_changed_signal ();
return new_hotlist;
}
void *
hdata_search (struct t_hdata *hdata, void *pointer, const char *search, int move)
{
char *result;
int rc;
if (!hdata || !pointer || !search || !search[0] || (move == 0))
return NULL;
/* clear or create hashtable with pointer for search */
if (hdata_search_pointers)
{
hashtable_remove_all (hdata_search_pointers);
}
else
{
hdata_search_pointers = hashtable_new (32,
DOGECHAT_HASHTABLE_STRING,
DOGECHAT_HASHTABLE_POINTER,
NULL,
NULL);
}
/*
* create hashtable with extra vars (empty hashtable)
* (hashtable would be created in eval_expression(), but it's created here
* so it will not be created for each call to eval_expression())
*/
if (!hdata_search_extra_vars)
{
hdata_search_extra_vars = hashtable_new (32,
DOGECHAT_HASHTABLE_STRING,
DOGECHAT_HASHTABLE_STRING,
NULL,
NULL);
}
if (!hdata_search_options)
{
hdata_search_options = hashtable_new (32,
DOGECHAT_HASHTABLE_STRING,
DOGECHAT_HASHTABLE_STRING,
NULL,
NULL);
if (hdata_search_options)
hashtable_set (hdata_search_options, "type", "condition");
}
while (pointer)
{
/* set pointer in hashtable (used for evaluating expression) */
hashtable_set (hdata_search_pointers, hdata->name, pointer);
/* evaluate expression */
result = eval_expression (search, hdata_search_pointers,
hdata_search_extra_vars,
hdata_search_options);
rc = eval_is_true (result);
if (result)
free (result);
if (rc)
return pointer;
pointer = hdata_move (hdata, pointer, move);
}
return NULL;
}
char *
gui_chat_get_time_string (time_t date)
{
char text_time[128], text_time2[(128*3)+16], text_time_char[2];
char *text_with_color;
int i, time_first_digit, time_last_digit, last_color;
struct tm *local_time;
if (date == 0)
return NULL;
if (!CONFIG_STRING(config_look_buffer_time_format)
|| !CONFIG_STRING(config_look_buffer_time_format)[0])
return NULL;
local_time = localtime (&date);
if (!local_time)
return NULL;
if (strftime (text_time, sizeof (text_time),
CONFIG_STRING(config_look_buffer_time_format),
local_time) == 0)
return NULL;
if (strstr (text_time, "${"))
{
text_with_color = eval_expression (text_time, NULL, NULL, NULL);
if (text_with_color)
{
if (strcmp (text_time, text_with_color) != 0)
return text_with_color;
free (text_with_color);
}
}
time_first_digit = -1;
time_last_digit = -1;
i = 0;
while (text_time[i])
{
if (isdigit ((unsigned char)text_time[i]))
{
if (time_first_digit == -1)
time_first_digit = i;
time_last_digit = i;
}
i++;
}
text_time2[0] = '\0';
text_time_char[1] = '\0';
last_color = -1;
i = 0;
while (text_time[i])
{
text_time_char[0] = text_time[i];
if (time_first_digit < 0)
{
if (last_color != GUI_COLOR_CHAT_TIME)
{
strcat (text_time2, GUI_COLOR(GUI_COLOR_CHAT_TIME));
last_color = GUI_COLOR_CHAT_TIME;
}
strcat (text_time2, text_time_char);
}
else
{
if ((i < time_first_digit) || (i > time_last_digit))
{
if (last_color != GUI_COLOR_CHAT_DELIMITERS)
{
strcat (text_time2, GUI_COLOR(GUI_COLOR_CHAT_DELIMITERS));
last_color = GUI_COLOR_CHAT_DELIMITERS;
}
strcat (text_time2, text_time_char);
}
else
{
if (isdigit ((unsigned char)text_time[i]))
{
if (last_color != GUI_COLOR_CHAT_TIME)
{
strcat (text_time2, GUI_COLOR(GUI_COLOR_CHAT_TIME));
last_color = GUI_COLOR_CHAT_TIME;
}
strcat (text_time2, text_time_char);
}
else
{
if (last_color != GUI_COLOR_CHAT_TIME_DELIMITERS)
{
strcat (text_time2,
GUI_COLOR(GUI_COLOR_CHAT_TIME_DELIMITERS));
last_color = GUI_COLOR_CHAT_TIME_DELIMITERS;
}
strcat (text_time2, text_time_char);
}
}
}
i++;
}
return strdup (text_time2);
}
static lisp_obj *apply(lisp_expr_application *app, lisp_env *env, lisp_err *err)
{
lisp_obj *callable = FORCE_VALUE(app->proc, env, err);
if (! callable){
return NULL;
}
lisp_obj *res = NIL;
/* Internal procedure */
if (callable->type == PROC){
/* Eval args */
lisp_obj **args = calloc(app->nparams, sizeof(lisp_obj*));
for (size_t i=0; i<app->nparams; i++){
lisp_obj *arg = FORCE_VALUE(app->params[i], env, err);
if (! arg){
for (size_t j=0; j<i; j++){
release(args[j]);
}
free(args);
return NULL;
}
args[i] = arg;
}
/* Eval internal */
res = callable->value.p(app->nparams, args);
/* Free args */
for (size_t i=0; i<app->nparams; i++){
release(args[i]);
}
free(args);
}
/* Lisp func */
else if (callable->type == LAMBDA){
lisp_lambda *lambda = &(callable->value.l);
lisp_expr_lambda *lambda_expr = &(lambda->declaration->value.mklambda);
/* Check arity */
if (app->nparams != lambda_expr->nparams){
raise_error(err, WRONG_ARITY, "Arity error ! Expected %d params, got %d",
lambda_expr->nparams, app->nparams);
return NULL;
}
/* Extend env */
lisp_env *locals = create_env(lambda->context);
for (size_t i=0; i<lambda_expr->nparams; i++){
lisp_obj *param = eval_expression(app->params[i], env, err);
if (! param){
release_env(locals);
return NULL;
}
DEBUG("Extend env with %s", lambda_expr->param_names[i]);
release(set_env(locals, lambda_expr->param_names[i], param));
}
if (enable_debug){
printf("\033[1mCALL\033[0m ");
dump_expr(lambda_expr->body);
printf(" with env\n");
dump_env(locals);
}
/* Wrap in thunk for trampoline */
res = make_thunk(lambda_expr->body, locals);
release_env(locals);
}
else {
lisp_print(callable);
raise_error(err, NOT_CALLABLE, "CANNOT CALL obj %p", callable);
return NULL;
}
release(callable);
return res;
}
