/* Evaluate an S-expression */
long
l_eval(long s)
{
long v, f, a, av[2];
int n;
switch(D_GET_TAG(s)){
case TAG_NIL: /* self-evaluating objects */
case TAG_T:
case TAG_INT:
v = s;
break;
case TAG_SYMB: /* symbol ... refer to the symbol table */
if ((v = t_symb_val[D_GET_DATA(s)]) == TAG_UNDEF)
return err_msg(errmsg_sym_undef, 1, s);
break;
case TAG_CONS: /* cons ... function call */
f = l_car(s); /* function name or lambda exp */
a = l_cdr(s); /* actual argument list */
#ifndef minimalistic
if ((D_GET_TAG(f) == TAG_CONS) && (D_GET_TAG(l_car(f)) == TAG_SYMB)
&& ((D_GET_DATA(l_car(f)) == KW_LAMBDA))){ /* lambda exp */
if (eval_args(f, a, av, FTYPE_ANY_ARGS) < 0)
return -1;
v = apply(l_cdr(f), av[0], list_len(l_car(l_cdr(f))));
} else
#endif
if (D_GET_TAG(f) == TAG_SYMB){
n = FTYPE_GET_NARGS(t_symb_ftype[D_GET_DATA(f)]);
switch (FTYPE_GET_TYPE(t_symb_ftype[D_GET_DATA(f)])){
case FTYPE_UNDEF:
return err_msg(errmsg_func_undef, 1, f);
case FTYPE_SPECIAL:
v = special(f, a);
break;
case FTYPE_SYS:
if (eval_args(f, a, av, n) < 0)
return -1;
v = fcall(f, av/*, n*/);
break;
case FTYPE_USER:
if (eval_args(f, a, av, FTYPE_ANY_ARGS) < 0)
return -1;
v = apply(f, av[0], n);
}
} else {
return err_msg(errmsg_ill_call, 1, s);
}
break;
}
return v;
}
static ciapos_sexp ciapos_vm_eval_withstack(ciapos_vm *self, ciapos_sexp stack, ciapos_sexp expr) {
expr = macroexpand(self, expr);
switch (expr.tag) {
case CIAPOS_TAGNIL: case CIAPOS_TAGINT: case CIAPOS_TAGREAL: case CIAPOS_TAGSTR: case CIAPOS_TAGOPAQUE:
case CIAPOS_TAGFN: return expr;
case CIAPOS_TAGSYM: return lookup(stack, expr.symbol);
case CIAPOS_TAGTUP: default:
assert(expr.tuple->length == 2);
ciapos_sexp fexpr = ciapos_tuple_get(expr, 0);
if (fexpr.tag == CIAPOS_TAGSYM) {
if (fexpr.symbol == ciapos_symbolof(&self->registry, "std:quote")) {
ciapos_sexp args = ciapos_tuple_get(expr, 1);
assert(args.tag == CIAPOS_TAGTUP);
assert(args.tuple->length == 2);
assert(ciapos_tuple_get(args, 1).tag == CIAPOS_TAGNIL);
return ciapos_tuple_get(args, 0);
}
if (fexpr.symbol == ciapos_symbolof(&self->registry, "std:lambda")) {
ciapos_sexp args = ciapos_tuple_get(expr, 1);
return parsefn(self, stack, args);
}
if (fexpr.symbol == ciapos_symbolof(&self->registry, "std:env")) {
assert(ciapos_tuple_get(expr, 1).tag == CIAPOS_TAGNIL);
return stack;
}
}
ciapos_sexp function = ciapos_vm_eval_withstack(self, stack, fexpr);
assert(function.tag == CIAPOS_TAGFN);
ciapos_sexp args = eval_args(self, stack, ciapos_tuple_get(expr, 1));
return ciapos_function_eval(function, self, args);
}
}
static ciapos_sexp eval_args(ciapos_vm *self, ciapos_sexp stack, ciapos_sexp args) {
if (args.tag == CIAPOS_TAGNIL) return args;
assert(args.tag == CIAPOS_TAGTUP);
assert(args.tuple->length == 2);
ciapos_sexp result = ciapos_mktuple(&self->top_of_heap, 2);
ciapos_tuple_put(result, 0, ciapos_vm_eval_withstack(self, stack, ciapos_tuple_get(args, 0)));
ciapos_tuple_put(result, 1, eval_args(self, stack, ciapos_tuple_get(args, 1)));
return result;
}
/* Eval the args given to -test and computes the function, unused */
ast_st* eval_args(int argc, const char ** argv, int par, int * index) {
ast_st *tmp1, *tmp2;
kind_en op = Nothing;
int i;
for (i = 0; i < argc; i++) {
if (!strcmp(argv[i],"(")) {
tmp2 = eval_args(argc-i, argv+i+1, 1, index);
if (tmp2 == NULL) return NULL;
i += *index;
}
else if (!strcmp(argv[i], ")"))
if (par) {
*index = i+1;
return tmp1;
}
else {
printf("Closing parenthesis unmatched\n");
return NULL;
}
else if (is_op(argv[i])) {
op = get_op(argv[i]);
}
else {
int val = !strcmp(argv[i], "") ? 0 : atoi(argv[i]);
tmp2 = create_int(val);
if (op != Nothing) {
tmp1 = create_node(op, tmp1, tmp2);
op = Nothing;
} else tmp1 = tmp2;
}
}
if (!par)
return tmp1;
else {
printf("Opening parenthesis unmatched\n");
return NULL;
}
}
/**
Evaluate the argument list (as supplied by complete -a) and insert
any return matching completions. Matching is done using \c
copy_strings_with_prefix, meaning the completion may contain
wildcards. Logically, this is not always the right thing to do, but
I have yet to come up with a case where this matters.
\param str The string to complete.
\param args The list of option arguments to be evaluated.
\param desc Description of the completion
\param comp_out The list into which the results will be inserted
*/
static void complete_from_args( const wchar_t *str,
const wchar_t *args,
const wchar_t *desc,
array_list_t *comp_out,
int flags )
{
array_list_t possible_comp;
al_init( &possible_comp );
proc_push_interactive(0);
eval_args( args, &possible_comp );
proc_pop_interactive();
complete_strings( comp_out, str, desc, 0, &possible_comp, flags );
al_foreach( &possible_comp, &free );
al_destroy( &possible_comp );
}
Variable* run_function(Interpretator *interpretator, Function *f, Array *args)
{
//Variable *return_var=undefined;
int i;
int *prev_base;
//if(f->return_var)
//return_var=interpretator_add_var(interpretator, f->return_var);
if(f->return_var)
interpretator->stack_head++;
if(args)
eval_args(interpretator, args, f->args);
prev_base=interpretator->stack_base;
interpretator->stack_base=(int*)interpretator->stack_head;
*interpretator->stack_base=prev_base;
interpretator->stack_head=(int*)interpretator->stack_head+f->variables->length+1;
execute(interpretator, f->body);
interpretator->stack_base=*(int*)interpretator->stack_base;
if(f->return_var)
{
printf("\n<function ");
str_print(f->name);
printf(" return ");
str_print(f->return_var->name);
printf(">\n");
}
return f->return_var;
//return return_var;
}
static double eval_item(const char *buf, int *pos) /* item = -item | +item | int | var | (expr) */
{
double rv = 0.0;
void *data;
int tlen, nargs, xargs;
DB(int i);
FunctionPtr fn;
DB(char *fname);
Token tok;
DB(printf("-- eval_item(\"%s\", &pos=%p pos=%d)\n", buf+*pos, pos, *pos));
tok = pull_token(buf, pos);
if(G_eval_error)
return rv;
DB(printf("-- item token type '%c' = ", tok.type));
switch(tok.type)
{
case '+': /* positive */
DB(printf("positive\n"));
rv = eval_fact(buf, pos);
break;
case '-': /* negative */
DB(printf("negative\n"));
rv = -eval_fact(buf, pos);
break;
case 'v': /* variable */
DB(printf("variable name '%s'=%f\n", tok.str, tok.value));
rv = tok.value;
break;
case 'f': /* function */
DB(printf("function name '%s'=%p(%d)\n", tok.str, tok.fn, tok.args));
tlen = tok.args;
nargs = tok.args;
xargs = nargs;
data = tok.data;
fn = tok.fn;
DB(fname = tok.str);
tok = pull_token(buf, pos);
if(G_eval_error == 0)
{
if(tok.type != '(')
G_eval_error = EVAL_SYNTAX_ERROR;
else
{
double *targ = NULL;
if(tlen > 0)
{
targ = (double*)lalloc(sizeof(double)*tlen);
if(targ == NULL)
{
G_eval_error = EVAL_MEM_ERROR;
break;
}
}else
tlen = 0;
if(eval_args(buf, pos, &nargs, &targ, &tlen, 0))
break;
DB(printf("-- item %d arguments\n", nargs));
if(xargs < 0)
{
if(nargs < 1)
{
DB(printf("-- item too few arguments\n"));
G_eval_error = EVAL_ARGS_ERROR;
break;
}
}else if(nargs != xargs)
{
DB(printf("-- item bad argument count (%d) need %d\n",
nargs, xargs));
G_eval_error = EVAL_ARGS_ERROR;
break;
}
tok = pull_token(buf, pos);
if(tok.type != ')')
G_eval_error = EVAL_SYNTAX_ERROR;
else if(G_eval_error == 0)
{
DB(printf("-- call function [%p] with %d args [%p]\n",
fn, nargs, targ));
DB(printf("-- %s(%f", fname, targ[0]));
DB(for(i=1;i<nargs;i++)printf(",%f",targ[i]));
DB(printf(")\n"));
if(fn(nargs, targ, &rv, data) != 0)
G_eval_error = EVAL_FUNCTION_ERROR;
DB(printf("-- rv = %f\n", rv));
}
}
}
break;
case 'n': /* number */
DB(printf("number value '%s'=%f\n", tok.str, tok.value));
rv = tok.value;
break;
case '(':
DB(printf("start grouping\n"));
rv = eval_expr(buf, pos);
tok = pull_token(buf, pos);
if(tok.type != ')')
G_eval_error = EVAL_SYNTAX_ERROR;
break;
default:
DB(printf("PUSHBACK\n"));
push_token(tok);
}
int evaluate(int exp_id) {
if (DEBUG) {
print(exp_id);
indent += 1;
}
if (ATOM(exp_id)) {
int found = find_env(exp_id);
if (!NILP(found)) {
expression[exp_id] = REMOVE_BIT(found);
}
} else {
switch (expression[CAR(exp_id)]) {
// car
case 1:
evaluate(CADR(exp_id));
if (ATOM(CADR(exp_id))) {
error(LIST_EXPECTED);
}
expression[exp_id] = expression[CAADR(exp_id)];
break;
// cdr
case 2:
evaluate(CADR(exp_id));
if (ATOM(CADR(exp_id))) {
error(LIST_EXPECTED);
}
expression[exp_id] = expression[CDR(CADR(exp_id))];
break;
// cons
case 3:
evaluate(CADR(exp_id));
evaluate(CADDR(exp_id));
expression[exp_id] = CONS(CADR(exp_id), CADDR(exp_id));
break;
// quote
case 4:
expression[exp_id] = expression[CADR(exp_id)];
break;
// eq
case 5:
evaluate(CADR(exp_id));
evaluate(CADDR(exp_id));
if (expression[CADR(exp_id)] == expression[CADDR(exp_id)]) {
expression[exp_id] = L_T;
} else {
expression[exp_id] = L_NIL;
}
break;
// atom
case 6:
evaluate(CADR(exp_id));
if (ATOM(CADR(exp_id))) {
expression[exp_id] = L_T;
} else {
expression[exp_id] = L_NIL;
}
break;
// cond
case 7:
evaluate_cond(CDR(exp_id));
expression[exp_id] = expression[CDR(exp_id)];
break;
// print
case 8:
evaluate(CADR(exp_id));
print(CADR(exp_id));
expression[exp_id] = expression[CADR(exp_id)];
break;
// apply
case 12:
{
int callee = CADR(exp_id);
int args = CDDR(exp_id);
eval_args(args);
before_call();
// if expression stack is not sufficient,
// you can save and restore max id here
if (expression[CAR(callee)] == L_LAMBDA) {
int new_exp_id = move_exp(CADDR(callee));
update_environment(CADR(callee), args);
evaluate(new_exp_id);
expression[exp_id] = expression[new_exp_id];
} else if (expression[CAR(callee)] == L_LABEL) {
int lambda_name = CADR(callee);
int lambda = CADDR(callee);
int new_exp_id = 0;
if (ATOM(lambda_name)) {
env[(call_depth << 8) + expression[lambda_name]] = SET_BIT(expression[lambda]);
} else {
error(INVALID_LABEL_NAME);
}
new_exp_id = move_exp(CADDR(lambda));
update_environment(CADR(lambda), args);
evaluate(new_exp_id);
expression[exp_id] = expression[new_exp_id];
} else {
error(NOT_LAMBDA);
}
after_call();
}
break;
default:
{
int found = find_env(CAR(exp_id));
if (!NILP(found)) {
int cdr = (REMOVE_BIT(found) << 16) >> 16;
int new_exp_id = 0;
int args = CDR(exp_id);
eval_args(args);
before_call();
new_exp_id = move_exp(CADR(cdr));
update_environment(CAR(cdr), args);
evaluate(new_exp_id);
expression[exp_id] = expression[new_exp_id];
after_call();
} else {
print(exp_id);
error(FUNCTION_NOT_FOUND);
}
}
break;
}
