void eval(BOOLEAN do_gc)
{
static unsigned int count = 0;
OBJECT_PTR exp = car(reg_next_expression);
OBJECT_PTR opcode = car(exp);
pin_globals();
if(do_gc)
{
count++;
if(count == GC_FREQUENCY)
{
gc(false, true);
count = 0;
}
}
if(opcode == APPLY && profiling_in_progress)
{
last_operator = reg_accumulator;
if(prev_operator != NIL)
{
OBJECT_PTR operator_to_be_used;
hashtable_entry_t *e;
unsigned int count;
unsigned int mem_alloc;
double elapsed_wall_time;
double elapsed_cpu_time;
double temp1 = get_wall_time();
clock_t temp2 = clock();
unsigned int temp3 = memory_allocated();
profiling_datum_t *pd = (profiling_datum_t *)malloc(sizeof(profiling_datum_t));
if(IS_SYMBOL_OBJECT(prev_operator))
operator_to_be_used = prev_operator;
else
{
OBJECT_PTR res = get_symbol_from_value(prev_operator, reg_current_env);
if(car(res) != NIL)
operator_to_be_used = cdr(res);
else
operator_to_be_used = cons(LAMBDA,
cons(get_params_object(prev_operator),
cons(car(get_source_object(prev_operator)), NIL)));
}
e = hashtable_get(profiling_tab, (void *)operator_to_be_used);
if(e)
{
profiling_datum_t *pd = (profiling_datum_t *)e->value;
count = pd->count + 1;
elapsed_wall_time = pd->elapsed_wall_time + temp1 - wall_time_var;
elapsed_cpu_time = pd->elapsed_cpu_time + (temp2 - cpu_time_var) * 1.0 / CLOCKS_PER_SEC;
mem_alloc = pd->mem_allocated + temp3 - mem_alloc_var;
hashtable_remove(profiling_tab, (void *)operator_to_be_used);
free(pd);
}
else
{
count = 1;
elapsed_wall_time = temp1 - wall_time_var;
elapsed_cpu_time = (temp2 - cpu_time_var) * 1.0 / CLOCKS_PER_SEC;
mem_alloc = temp3 - mem_alloc_var;
}
pd->count = count;
pd->elapsed_wall_time = elapsed_wall_time;
pd->elapsed_cpu_time = elapsed_cpu_time;
pd->mem_allocated = mem_alloc;
hashtable_put(profiling_tab, (void *)operator_to_be_used, (void *)pd);
}
wall_time_var = get_wall_time();
cpu_time_var = clock();
mem_alloc_var = memory_allocated();
prev_operator = reg_accumulator;
}
if(opcode == HALT)
{
halt_op();
}
else if(opcode == REFER)
{
if(refer(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == CONSTANT)
{
if(constant(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == CLOSE)
{
if(closure(exp))
return;
reg_next_expression = fifth(exp);
}
else if(opcode == MACRO)
{
if(macro(exp))
return;
reg_next_expression = CADDDDR(exp);
}
else if(opcode == TEST)
{
if(reg_accumulator != NIL)
reg_next_expression = CADR(exp);
else
reg_next_expression = CADDR(exp);
}
//Not using this WHILE; reverting
//to macro definition, as this
//version doesn't handle (BREAK)
else if(opcode == WHILE)
{
OBJECT_PTR cond = CADR(exp);
OBJECT_PTR body = CADDR(exp);
OBJECT_PTR ret = NIL;
while(1)
{
OBJECT_PTR temp = reg_current_stack;
reg_next_expression = cond;
while(car(reg_next_expression) != NIL)
{
eval(false);
if(in_error)
return;
}
if(reg_accumulator == NIL)
break;
reg_next_expression = body;
while(car(reg_next_expression) != NIL)
{
eval(false);
if(in_error)
return;
}
//to handle premature exits
//via RETURN-FROM
if(reg_current_stack != temp)
return;
ret = reg_accumulator;
}
reg_accumulator = ret;
reg_next_expression = CADDDR(exp);
}
else if(opcode == ASSIGN)
{
if(assign(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == DEFINE)
{
if(define(CADR(exp)))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == CONTI)
{
if(conti())
return;
reg_next_expression = CADR(exp);
}
else if(opcode == NUATE) //this never gets called
{
reg_current_stack = CADR(exp);
reg_accumulator = CADDR(exp);
reg_current_value_rib = NIL;
reg_next_expression = cons(CONS_RETURN_NIL, cdr(reg_next_expression));
}
else if(opcode == FRAME)
{
if(frame(exp))
return;
reg_next_expression = CADDR(exp);
}
else if(opcode == ARGUMENT)
{
if(argument())
return;
reg_next_expression = CADR(exp);
}
else if(opcode == APPLY)
{
apply_compiled();
}
else if(opcode == RETURN)
{
return_op();
}
}
int
main(int argc)
{
IloEnv env;
try {
IloModel model(env);
NumVarMatrix varOutput(env, J + current);
NumVar3Matrix varHelp(env, J + current);
Range3Matrix cons(env, J + current);
for (int j = 0; j <J + current; j++){
varOutput[j] = IloNumVarArray(env, K);
varHelp[j] = NumVarMatrix(env, K);
cons[j] = RangeMatrix(env, K);
for (int k = 0; k < K; k++){
varOutput[j][k] = IloNumVar(env, 0.0, IloInfinity);
varHelp[j][k] = IloNumVarArray(env, L);
cons[j][k] = IloRangeArray(env, C);
for (int l = 0; l < L; l++){
varHelp[j][k][l] = IloNumVar(env, 0.0, IloInfinity);
}
if (j > current){
cons[j][k][0] = IloRange(env, 0.0, 0.0);//will be used to express equality of varOutput, constraint (0)
cons[j][k][1] = IloRange(env, 0.0, IloInfinity);// constraint (1)
cons[j][k][2] = IloRange(env, -IloInfinity, T[j] - Tdc - Tblow[j] - Tslack);// constraint (2)
cons[j][k][3] = IloRange(env, Tfd[k], Tfd[k]);// constraint (3)
cons[j][k][4] = IloRange(env, 0.0, IloInfinity);// constraint (4)
cons[j][k][5] = IloRange(env, Tdf[k], IloInfinity);// constraint (5)
cons[j][k][6] = IloRange(env, T[j - a[k]] + Tcd, T[j - a[k]] + Tcd);// constraint (6)
cons[j][k][7] = IloRange(env, TlossD[k], IloInfinity);// constraint (7)
cons[j][k][8] = IloRange(env, TlossF[k], IloInfinity);// constraint (8)
}
}
}
populatebynonzero(model, varOutput, varHelp, cons);
IloCplex cplex(model);
// Optimize the problem and obtain solution.
if (!cplex.solve()) {
env.error() << "Failed to optimize LP" << endl;
throw(-1);
}
IloNumArray vals(env);
IloNumVar val(env);
//vars to save output
double TimeAvailable[J][K];
double TimeInstances[J][K][L];
double LK103[J][2];
env.out() << "Solution status = " << cplex.getStatus() << endl;
env.out() << "Solution value = " << cplex.getObjValue() << endl;
for (int j = current; j < current + J; ++j)
{
cplex.getValues(vals, varOutput[j]);
env.out() << "Seconds for load "<<j<<" = " << vals << endl;
/*for (int k = 0; k < K; k++){
TimeAvailable[j][k] = cplex.getValue(varOutput[j][k]);
}*/
}
for (int j = current; j < current + J; j++){
for (int k = 0; k < K; k++){
cplex.getValues(vals, varHelp[j][k]);
env.out() << "Time instances for spoon "<<k<<" in load "<<j<<" = " << vals << endl;
/*for (int l = 0; l < L; l++){
TimeInstances[j][k][l] = cplex.getValue(varHelp[j][k][l]);
}*/
}
}
for (int j = current + 2; j < J + current; j++){
LK103[j][0] = TimeInstances[j - 2][0][0];
LK103[j][1] = TimeInstances[j][0][5];
env.out() << "LK103, load " << j << " : " << LK103[j][1]-LK103[j][0] << endl;
}
/*cplex.getSlacks(vals, cons);
env.out() << "Slacks = " << vals << endl;
cplex.getDuals(vals, cons);
env.out() << "Duals = " << vals << endl;
cplex.getReducedCosts(vals, varOutput);
env.out() << "Reduced Costs = " << vals << endl;*/
cplex.exportModel("lpex1.lp");
}
catch (IloException& e) {
cerr << "Concert exception caught: " << e << endl;
}
catch (...) {
cerr << "Unknown exception caught" << endl;
}
env.end();
cin.get();
return 0;
} // END main
public: Val AddOpt(Val ty)
{ ASSERT(nil != ty); m_opts = cons(ty, m_opts); return ty; }
liste liste_test1 ()
{
return cons (1, cons (2, cons (3, cons (4, l_vide ())))) ;
}
/* Evaluate object
* NULL return value means Nothing
*/
object *eval(object *obj, env_hashtable *env)
{
object *cur, *eobj,
*last_pair, *t,
*ecar, *ecdr;
if (!obj)
return NULL;
/* Detect syntatic construction */
if (TYPE(obj) == OBJ_PAIR &&
TYPE(CAR(obj)) == OBJ_SYMBOL) {
t = CAR(obj);
if (strcmp("lambda", STR(t)) == 0) {
t = CDDR(obj);
t = cons(symbol("begin"), t);
eobj = compound_procedure(CADR(obj), t, env);
return eobj;
} else if (strcmp("define", STR(t)) == 0) {
eobj = eval(CADDR(obj), env);
env_hashtable_insert(env, STR(CADR(obj)), eobj);
return NULL; /* Not error, just nothing */
} else if (strcmp("begin", STR(t)) == 0) {
obj = CDR(obj);
eobj = NULL; /* Not error, just nothing */
while (obj != null_object) {
eobj = eval(CAR(obj), env);
obj = CDR(obj);
}
return eobj;
} else if (strcmp("apply", STR(t)) == 0) {
eobj = eval(CADR(obj), env);
t = eval(CADDR(obj), env);
return apply(eobj, t);
} else if (strcmp("quote", STR(t)) == 0) {
return CADR(obj);
}
}
/* Object evaluation */
switch (TYPE(obj)) {
case OBJ_NUMBER:
case OBJ_BOOLEAN:
return obj;
case OBJ_SYMBOL:
return env_hashtable_find(env, STR(obj));
case OBJ_PAIR:
cur = obj;
eobj = null_object;
last_pair = NULL;
while (cur != null_object &&
TYPE(cur) == OBJ_PAIR) {
t = cons(eval(CAR(cur), env), null_object);
if (!last_pair)
eobj = t;
else
CDR(last_pair) = t;
last_pair = t;
cur = CDR(cur);
}
ecar = CAR(eobj);
ecdr = CDR(eobj);
return apply(ecar, ecdr);
default:
return NULL;
}
}
Value
Parser::quoted(Symbol *quote)
{
return cons(quote, cons(parse(), NIL));
}
static Tree prepareRule(Tree rule)
{
return cons(lmap(preparePattern, hd(rule)), tl(rule));
}
/* An explicit control evaluator, taken almost directly from SICP, section
* 5.2. list is a flat list of expressions to evaluate. where is a label to
* begin at. Return value depends on where.
*/
NODE *evaluator(NODE *list, enum labels where) {
/* registers */
NODE *exp = NIL, /* the current expression */
*val = NIL, /* the value of the last expression */
*proc = NIL, /* the procedure definition */
*argl = NIL, /* evaluated argument list */
*unev = NIL, /* list of unevaluated expressions */
*stack = NIL, /* register stack */
*parm = NIL, /* the current formal */
*catch_tag = NIL,
*arg = NIL; /* the current actual */
/* registers that don't get reference counted, so we pretend they're ints */
FIXNUM vsp = 0, /* temp ptr into var_stack */
cont = 0, /* where to go next */
formals = (FIXNUM)NIL; /* list of formal parameters */
int i, nargs;
BOOLEAN tracing; /* are we tracing the current procedure? */
FIXNUM oldtailcall; /* in case of reentrant use of evaluator */
FIXNUM repcount; /* count for repeat */
FIXNUM old_ift_iff;
oldtailcall = tailcall;
old_ift_iff = ift_iff_flag;
save2(var,this_line);
assign(var, var_stack);
save2(fun,ufun);
cont = (FIXNUM)all_done;
numsave((FIXNUM)cont);
newcont(where);
goto fetch_cont;
begin_line:
ref(list);
assign(this_line, list);
newcont(end_line);
begin_seq:
make_tree(list);
if (!is_tree(list)) {
assign(val, UNBOUND);
goto fetch_cont;
}
assign(unev, tree__tree(list));
assign(val, UNBOUND);
goto eval_sequence;
end_line:
if (val != UNBOUND) {
if (NOT_THROWING) err_logo(DK_WHAT, val);
deref(val);
}
val = NIL;
deref(list);
goto fetch_cont;
/* ----------------- EVAL ---------------------------------- */
tail_eval_dispatch:
tailcall = 1;
eval_dispatch:
switch (nodetype(exp)) {
case QUOTE: /* quoted literal */
assign(val, node__quote(exp));
goto fetch_cont;
case COLON: /* variable */
assign(val, valnode__colon(exp));
while (val == UNBOUND && NOT_THROWING)
assign(val, err_logo(NO_VALUE, node__colon(exp)));
goto fetch_cont;
case CONS: /* procedure application */
if (tailcall == 1 && is_macro(car(exp)) &&
is_list(procnode__caseobj(car(exp)))) {
/* tail call to user-defined macro must be treated as non-tail
* because the expression returned by the macro
* remains to be evaluated in the caller's context */
assign(unev, NIL);
goto non_tail_eval;
}
assign(fun, car(exp));
if (cdr(exp) != NIL)
goto ev_application;
else
goto ev_no_args;
default:
assign(val, exp); /* self-evaluating */
goto fetch_cont;
}
ev_no_args:
/* Evaluate an application of a procedure with no arguments. */
assign(argl, NIL);
goto apply_dispatch; /* apply the procedure */
ev_application:
/* Evaluate an application of a procedure with arguments. */
assign(unev, cdr(exp));
assign(argl, NIL);
mixsave(tailcall,var);
num2save(val_status,ift_iff_flag);
save2(didnt_get_output,didnt_output_name);
eval_arg_loop:
if (unev == NIL) goto eval_args_done;
assign(exp, car(unev));
if (exp == Not_Enough_Node) {
if (NOT_THROWING)
err_logo(NOT_ENOUGH, NIL);
goto eval_args_done;
}
save(argl);
save2(unev,fun);
save2(ufun,last_ufun);
save2(this_line,last_line);
assign(var, var_stack);
tailcall = -1;
val_status = 1;
assign(didnt_get_output,
cons_list(0,fun,ufun,this_line,END_OF_LIST));
assign(didnt_output_name, NIL);
newcont(accumulate_arg);
goto eval_dispatch; /* evaluate the current argument */
accumulate_arg:
/* Put the evaluated argument into the argl list. */
reset_args(var);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
assign(last_call, fun);
restore2(unev,fun);
restore(argl);
while (NOT_THROWING && val == UNBOUND) {
assign(val, err_logo(DIDNT_OUTPUT, NIL));
}
push(val, argl);
pop(unev);
goto eval_arg_loop;
eval_args_done:
restore2(didnt_get_output,didnt_output_name);
num2restore(val_status,ift_iff_flag);
mixrestore(tailcall,var);
if (stopping_flag == THROWING) {
assign(val, UNBOUND);
goto fetch_cont;
}
assign(argl, reverse(argl));
/* --------------------- APPLY ---------------------------- */
apply_dispatch:
/* Load in the procedure's definition and decide whether it's a compound
* procedure or a primitive procedure.
*/
proc = procnode__caseobj(fun);
if (is_macro(fun)) {
num2save(val_status,tailcall);
val_status = 1;
newcont(macro_return);
}
if (proc == UNDEFINED) {
if (ufun != NIL) {
untreeify_proc(ufun);
}
if (NOT_THROWING)
assign(val, err_logo(DK_HOW, fun));
else
assign(val, UNBOUND);
goto fetch_cont;
}
if (is_list(proc)) goto compound_apply;
/* primitive_apply */
if (NOT_THROWING)
assign(val, (*getprimfun(proc))(argl));
else
assign(val, UNBOUND);
#define do_case(x) case x: goto x;
fetch_cont:
{
enum labels x = (enum labels)cont;
cont = (FIXNUM)car(stack);
numpop(&stack);
switch (x) {
do_list(do_case)
default: abort();
}
}
compound_apply:
#ifdef mac
check_mac_stop();
#endif
#ifdef ibm
check_ibm_stop();
#endif
if (tracing = flag__caseobj(fun, PROC_TRACED)) {
for (i = 0; i < trace_level; i++) print_space(writestream);
trace_level++;
ndprintf(writestream, "( %s ", fun);
}
/* Bind the actuals to the formals */
vsp = (FIXNUM)var_stack; /* remember where we came in */
for (formals = (FIXNUM)formals__procnode(proc);
formals != (FIXNUM)NIL;
formals = (FIXNUM)cdr((NODE *)formals)) {
parm = car((NODE *)formals);
if (nodetype(parm) == INT) break; /* default # args */
if (argl != NIL) {
arg = car(argl);
if (tracing) {
print_node(writestream, maybe_quote(arg));
print_space(writestream);
}
} else
arg = UNBOUND;
if (nodetype(parm) == CASEOBJ) {
if (not_local(parm,(NODE *)vsp)) {
push(parm, var_stack);
setobject(var_stack, valnode__caseobj(parm));
}
tell_shadow(parm);
setvalnode__caseobj(parm, arg);
} else if (nodetype(parm) == CONS) {
/* parm is optional or rest */
if (not_local(car(parm),(NODE *)vsp)) {
push(car(parm), var_stack);
setobject(var_stack, valnode__caseobj(car(parm)));
}
tell_shadow(car(parm));
if (cdr(parm) == NIL) { /* parm is rest */
setvalnode__caseobj(car(parm), argl);
break;
}
if (arg == UNBOUND) { /* use default */
save2(fun,var);
save2(ufun,last_ufun);
save2(this_line,last_line);
save2(didnt_output_name,didnt_get_output);
num2save(ift_iff_flag,val_status);
assign(var, var_stack);
tailcall = -1;
val_status = 1;
mixsave(formals,argl);
numsave(vsp);
assign(list, cdr(parm));
if (NOT_THROWING)
make_tree(list);
else
assign(list, NIL);
if (!is_tree(list)) {
assign(val, UNBOUND);
goto set_args_continue;
}
assign(unev, tree__tree(list));
assign(val, UNBOUND);
newcont(set_args_continue);
goto eval_sequence;
set_args_continue:
numrestore(vsp);
mixrestore(formals,argl);
parm = car((NODE *)formals);
reset_args(var);
num2restore(ift_iff_flag,val_status);
restore2(didnt_output_name,didnt_get_output);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
restore2(fun,var);
arg = val;
}
setvalnode__caseobj(car(parm), arg);
}
if (argl != NIL) pop(argl);
}
if (check_throwing) {
assign(val, UNBOUND);
goto fetch_cont;
}
vsp = 0;
if (tracing = flag__caseobj(fun, PROC_TRACED)) {
if (NOT_THROWING) print_char(writestream, ')');
new_line(writestream);
save(fun);
newcont(compound_apply_continue);
}
assign(val, UNBOUND);
assign(last_ufun, ufun);
assign(ufun, fun);
assign(last_line, this_line);
assign(this_line, NIL);
proc = procnode__caseobj(fun);
assign(list, bodylist__procnode(proc)); /* get the body ... */
make_tree_from_body(list);
if (!is_tree(list)) {
goto fetch_cont;
}
assign(unev, tree__tree(list));
if (NOT_THROWING) stopping_flag = RUN;
assign(output_node, UNBOUND);
if (val_status == 1) val_status = 2;
else if (val_status == 5) val_status = 3;
else val_status = 0;
eval_sequence:
/* Evaluate each expression in the sequence. Stop as soon as
* val != UNBOUND.
*/
if (!RUNNING || val != UNBOUND) {
goto fetch_cont;
}
if (nodetype(unev) == LINE) {
assign(this_line, unparsed__line(unev));
if (flag__caseobj(ufun, PROC_STEPPED)) {
char junk[20];
if (tracing) {
int i = 1;
while (i++ < trace_level) print_space(stdout);
}
print_node(stdout, this_line);
ndprintf(stdout, " >>> ");
input_blocking++;
#ifndef TIOCSTI
if (!setjmp(iblk_buf))
#endif
#ifdef __ZTC__
ztc_getcr();
#else
fgets(junk, 19, stdin);
#endif
input_blocking = 0;
update_coords('\n');
}
}
assign(exp, car(unev));
pop(unev);
if (is_list(exp) && (is_tailform(procnode__caseobj(car(exp))))) {
if (nameis(car(exp),Output) || nameis(car(exp),Op)) {
assign(didnt_get_output,
cons_list(0,car(exp),ufun,this_line,END_OF_LIST));
assign(didnt_output_name, NIL);
if (val_status == 2 || val_status == 3) {
val_status = 1;
assign(exp, cadr(exp));
goto tail_eval_dispatch;
} else if (ufun == NIL) {
err_logo(AT_TOPLEVEL,car(exp));
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status < 4) {
val_status = 1;
assign(exp, cadr(exp));
assign(unev, NIL);
goto non_tail_eval; /* compute value then give error */
}
} else if (nameis(car(exp),Stop)) {
if (ufun == NIL) {
err_logo(AT_TOPLEVEL,car(exp));
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status == 0 || val_status == 3) {
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status < 4) {
assign(didnt_output_name, fun);
assign(val, UNBOUND);
goto fetch_cont;
}
} else { /* maybeoutput */
assign(exp, cadr(exp));
val_status = 5;
goto tail_eval_dispatch;
}
}
if (unev == NIL) {
if (val_status == 2 || val_status == 4) {
assign(didnt_output_name, fun);
assign(unev, UNBOUND);
goto non_tail_eval;
} else {
goto tail_eval_dispatch;
}
}
if (is_list(car(unev)) && nameis(car(car(unev)),Stop)) {
if ((val_status == 0 || val_status == 3) && ufun != NIL) {
goto tail_eval_dispatch;
} else if (val_status < 4) {
assign(didnt_output_name, fun);
goto tail_eval_dispatch;
}
}
non_tail_eval:
save2(unev,fun);
num2save(ift_iff_flag,val_status);
save2(ufun,last_ufun);
save2(this_line,last_line);
save(var);
assign(var, var_stack);
tailcall = 0;
newcont(eval_sequence_continue);
goto eval_dispatch;
eval_sequence_continue:
reset_args(var);
restore(var);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
if (dont_fix_ift) {
num2restore(dont_fix_ift,val_status);
dont_fix_ift = 0;
} else
num2restore(ift_iff_flag,val_status);
restore2(unev,fun);
if (stopping_flag == MACRO_RETURN) {
if (unev == UNBOUND) assign(unev, NIL);
assign(unev, append(val, unev));
assign(val, UNBOUND);
stopping_flag = RUN;
if (unev == NIL) goto fetch_cont;
} else if (val_status < 4) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2 && NOT_THROWING) {
assign(didnt_output_name,Output);
err_logo(DIDNT_OUTPUT,Output);
}
if (val == UNBOUND && val_status == 1 && NOT_THROWING) {
assign(didnt_output_name,Stop);
err_logo(DIDNT_OUTPUT,Output);
}
goto fetch_cont;
}
}
if (val != UNBOUND) {
err_logo((unev == NIL ? DK_WHAT_UP : DK_WHAT), val);
assign(val, UNBOUND);
}
if (NOT_THROWING && (unev == NIL || unev == UNBOUND)) {
if (val_status != 4) err_logo(DIDNT_OUTPUT,NIL);
goto fetch_cont;
}
goto eval_sequence;
compound_apply_continue:
/* Only get here if tracing */
restore(fun);
--trace_level;
if (NOT_THROWING) {
for (i = 0; i < trace_level; i++) print_space(writestream);
print_node(writestream, fun);
if (val == UNBOUND)
ndprintf(writestream, " stops\n");
else {
ref(val);
ndprintf(writestream, " outputs %s\n", maybe_quote(val));
deref(val);
}
}
goto fetch_cont;
/* --------------------- MACROS ---------------------------- */
macro_return:
num2restore(val_status,tailcall);
while (!is_list(val) && NOT_THROWING) {
assign(val,err_logo(ERR_MACRO,val));
}
if (NOT_THROWING) {
if (is_cont(val)) {
newcont(cont__cont(val));
val->n_car = NIL;
assign(val, val__cont(val));
goto fetch_cont;
}
macro_reval:
if (tailcall == 0) {
make_tree(val);
stopping_flag = MACRO_RETURN;
if (!is_tree(val)) assign(val, NIL);
else assign(val, tree__tree(val));
goto fetch_cont;
}
assign(list,val);
goto begin_seq;
}
assign(val, UNBOUND);
goto fetch_cont;
runresult_continuation:
assign(list, val);
newcont(runresult_followup);
val_status = 5;
goto begin_seq;
runresult_followup:
if (val == UNBOUND) {
assign(val, NIL);
} else {
assign(val, cons(val, NIL));
}
goto fetch_cont;
repeat_continuation:
assign(list, cdr(val));
repcount = getint(car(val));
repeat_again:
assign(val, UNBOUND);
if (repcount == 0) goto fetch_cont;
mixsave(repcount,list);
num2save(val_status,tailcall);
val_status = 4;
newcont(repeat_followup);
goto begin_seq;
repeat_followup:
if (val != UNBOUND && NOT_THROWING) {
ref(val);
err_logo(DK_WHAT, val);
unref(val);
}
num2restore(val_status,tailcall);
mixrestore(repcount,list);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
goto fetch_cont;
}
}
if (repcount > 0) /* negative means forever */
--repcount;
#ifdef mac
check_mac_stop();
#endif
#ifdef ibm
check_ibm_stop();
#endif
if (RUNNING) goto repeat_again;
assign(val, UNBOUND);
goto fetch_cont;
catch_continuation:
assign(list, cdr(val));
assign(catch_tag, car(val));
if (compare_node(catch_tag,Error,TRUE) == 0) {
push(Erract, var_stack);
setobject(var_stack, valnode__caseobj(Erract));
setvalnode__caseobj(Erract, UNBOUND);
}
save(catch_tag);
save2(didnt_output_name,didnt_get_output);
num2save(val_status,tailcall);
newcont(catch_followup);
val_status = 5;
goto begin_seq;
catch_followup:
num2restore(val_status,tailcall);
restore2(didnt_output_name,didnt_get_output);
restore(catch_tag);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
}
}
if (stopping_flag == THROWING &&
compare_node(throw_node, catch_tag, TRUE) == 0) {
throw_node = reref(throw_node, UNBOUND);
stopping_flag = RUN;
assign(val, output_node);
}
goto fetch_cont;
begin_apply:
/* This is for lapply. */
assign(fun, car(val));
while (nodetype(fun) == ARRAY && NOT_THROWING)
assign(fun, err_logo(APPLY_BAD_DATA, fun));
assign(argl, cadr(val));
assign(val, UNBOUND);
while (!is_list(argl) && NOT_THROWING)
assign(argl, err_logo(APPLY_BAD_DATA, argl));
if (NOT_THROWING && fun != NIL) {
if (is_list(fun)) { /* template */
if (is_list(car(fun)) && cdr(fun) != NIL) {
/* lambda form */
formals = (FIXNUM)car(fun);
numsave(tailcall);
tailcall = 0;
llocal((NODE *)formals); /* bind the formals locally */
numrestore(tailcall);
for ( ;
formals && argl && NOT_THROWING;
formals = (FIXNUM)cdr((NODE *)formals),
assign(argl, cdr(argl)))
setvalnode__caseobj(car((NODE *)formals), car(argl));
assign(val, cdr(fun));
goto macro_reval;
} else { /* question-mark form */
save(qm_list);
assign(qm_list, argl);
assign(list, fun);
make_tree(list);
if (list == NIL || !is_tree(list)) {
goto qm_failed;
}
assign(unev, tree__tree(list));
save2(didnt_output_name,didnt_get_output);
num2save(val_status,tailcall);
newcont(qm_continue);
val_status = 5;
goto eval_sequence;
qm_continue:
num2restore(val_status,tailcall);
restore2(didnt_output_name,didnt_get_output);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
}
}
qm_failed:
restore(qm_list);
goto fetch_cont;
}
} else { /* name of procedure to apply */
int min, max, n;
NODE *arg;
assign(fun, intern(fun));
if (procnode__caseobj(fun) == UNDEFINED && NOT_THROWING &&
fun != Null_Word)
silent_load(fun, NULL); /* try ./<fun>.lg */
if (procnode__caseobj(fun) == UNDEFINED && NOT_THROWING &&
fun != Null_Word)
silent_load(fun, logolib); /* try <logolib>/<fun> */
proc = procnode__caseobj(fun);
while (proc == UNDEFINED && NOT_THROWING) {
assign(val, err_logo(DK_HOW_UNREC, fun));
}
if (NOT_THROWING) {
if (nodetype(proc) == CONS) {
min = getint(minargs__procnode(proc));
max = getint(maxargs__procnode(proc));
} else {
if (getprimdflt(proc) < 0) { /* special form */
err_logo(DK_HOW_UNREC, fun); /* can't apply */
goto fetch_cont;
} else {
min = getprimmin(proc);
max = getprimmax(proc);
}
}
for (n = 0, arg = argl; arg != NIL; n++, arg = cdr(arg));
if (n < min) {
err_logo(NOT_ENOUGH, NIL);
} else if (n > max && max >= 0) {
err_logo(TOO_MUCH, NIL);
} else {
goto apply_dispatch;
}
}
}
}
goto fetch_cont;
all_done:
tailcall = oldtailcall;
ift_iff_flag = old_ift_iff;
restore2(fun,ufun);
reset_args(var);
restore2(var,this_line);
deref(argl);deref(unev);deref(stack);deref(catch_tag);deref(exp);
return(val);
}
/*! \brief Concatenate two lists.
*
* Create a list by joining two lists together.
*
* \param list_a A list to become the head of new list.
* \param list_b A list to become the tail of new list.
* \return A list with the elements of \a list_a followed by the
* elements of \a list_b.
*/
sexp append(sexp list_a, sexp list_b) {
if (c_bool(null(list_a))) { return list_b; }
return cons(car(list_a), append(cdr(list_a), list_b));
}
bool Porter_Stemmer::cvc(int i) {
if (i < k0+2 || !cons(i) || cons(i-1) || !cons(i-2)) return false;
int ch = b[i];
if (ch == 'w' || ch == 'x' || ch == 'y') return false;
return true;
}
/* nondestructive append */
NODE *append(NODE *a, NODE *b) {
NODE *result;
if (a == NIL) return b;
return cons(car(a), append(cdr(a), b));
}
bool Porter_Stemmer::doublec(int j) {
if (j < k0+1) return false;
if (b[j] != b[j-1]) return false;
return cons(j);
}
bool Porter_Stemmer::vowelinstem() {
int i;
for (i = k0; i <= j; i++) if (! cons(i)) return true;
return false;
}
OBJECT_PTR eval_backquote(OBJECT_PTR form)
{
OBJECT_PTR car_obj;
assert(is_valid_object(form));
if(is_atom(form))
return form;
car_obj = car(form);
assert(is_valid_object(car_obj));
if(IS_SYMBOL_OBJECT(car_obj))
{
char buf[SYMBOL_STRING_SIZE];
print_symbol(car_obj, buf);
if(car_obj == COMMA)
{
OBJECT_PTR temp = compile(CADR(form), NIL);
#ifdef WIN32
if(temp == ERROR1)
#else
if(temp == ERROR)
#endif
{
throw_generic_exception("Backquote evaluation(1): compile failed");
return NIL;
}
reg_next_expression = cons(cons(FRAME, cons(cons(CONS_HALT_NIL, CADR(form)),
cons(temp, CADR(form)))),
CADR(form));
reg_current_value_rib = NIL;
while(car(reg_next_expression) != NIL)
{
//print_object(car(reg_next_expression));printf("\n");getchar();
eval(false);
if(in_error)
{
throw_generic_exception("Evaluation of backquote failed(1)");
return NIL;
}
}
reg_next_expression = cons(CONS_RETURN_NIL, cdr(reg_next_expression));
reg_current_value_rib = NIL;
return reg_accumulator;
}
}
if(form_contains_comma_at(form))
{
//1. loop through elements in form
//2. if element is not comma-at, call eval_backquote on
// it and append it to the result list without splicing
//3. if it is comma-at, get its symbol value and
// splice the value to the result list
//4. return the result list
OBJECT_PTR result = NIL;
OBJECT_PTR rest = form;
while(rest != NIL)
{
OBJECT_PTR ret;
OBJECT_PTR obj;
if(IS_CONS_OBJECT(car(rest)) &&
IS_SYMBOL_OBJECT(CAAR(rest)))
{
char buf[SYMBOL_STRING_SIZE];
print_symbol(CAAR(rest), buf);
if(CAAR(rest) == COMMA_AT)
{
OBJECT_PTR temp = compile(CADAR(rest), NIL);
#ifdef WIN32
if(temp == ERROR1)
#else
if(temp == ERROR)
#endif
{
throw_generic_exception("Backquote evaluation(2): compile failed");
return NIL;
}
reg_next_expression = cons(cons(FRAME, cons(cons(CONS_HALT_NIL, CADAR(rest)),
cons(temp, CADAR(rest)))),
CADAR(rest));
reg_current_value_rib = NIL;
while(car(reg_next_expression) != NIL)
{
eval(false);
if(in_error)
{
throw_generic_exception("Evaluation of backquote failed(2)");
return NIL;
}
}
reg_next_expression = cons(CONS_RETURN_NIL, cdr(reg_next_expression));
reg_current_value_rib = NIL;
obj = reg_accumulator;
if(result == NIL)
result = obj;
else
set_heap(last_cell(result) & POINTER_MASK, 1, obj);
}
else
{
obj = eval_backquote(car(rest));
if(result == NIL)
result = cons(obj, NIL);
else
set_heap(last_cell(result) & POINTER_MASK, 1, cons(obj, NIL));
}
}
else
{
obj = eval_backquote(car(rest));
if(result == NIL)
result = cons(obj, NIL);
else
set_heap(last_cell(result) & POINTER_MASK, 1, cons(obj, NIL));
}
rest = cdr(rest);
}
return result;
}
return cons(eval_backquote(car(form)),
eval_backquote(cdr(form)));
}
static at *
four_integers(int i1, int i2, int i3, int i4)
{
return cons(NEW_NUMBER(i1), cons(NEW_NUMBER(i2), two_integers(i3, i4)));
}
static Tree listn (int n, Tree e)
{
return (n<= 0) ? gGlobal->nil : cons(e, listn(n-1,e));
}
static at *
event_to_list(int event, int xd, int yd, int xu, int yu, int *pmods)
{
*pmods = -1;
/* events that do not update evshift and evcontrol */
if (event == EVENT_MOUSE_UP)
return cons(named("mouse-up"), four_integers(xd,yd,xu,yu));
if (event == EVENT_MOUSE_DRAG)
return cons(named("mouse-drag"), four_integers(xd,yd,xu,yu));
if (event == EVENT_RESIZE)
return cons(named("resize"), two_integers(xd,yd));
if (event == EVENT_DELETE)
return cons(named("delete"),NIL);
if (event == EVENT_SENDEVENT)
return cons(named("sendevent"), two_integers(xd,yd));
if (event == EVENT_EXPOSE)
return cons(named("expose"), two_integers(xd,yd));
if (event == EVENT_GLEXPOSE)
return cons(named("glexpose"), two_integers(xd,yd));
if (event >= EVENT_ASCII_MIN && event <= EVENT_ASCII_MAX)
{
char keyevent[2];
keyevent[0] = EVENT_TO_ASCII(event);
keyevent[1] = 0;
return cons(new_string(keyevent), two_integers(xd,yd));
}
/* events that update evshift and evcontrol */
*pmods = 0;
if (xu)
*pmods |= 1; /* shift */
if (yu)
*pmods |= 2; /* ctrl */
if (event == EVENT_MOUSE_DOWN)
return cons(named("mouse-down"), two_integers(xd,yd));
if (event == EVENT_HELP)
return cons(named("help"), two_integers(xd,yd));
if (event == EVENT_ARROW_UP)
return cons(named("arrow-up"), two_integers(xd,yd));
if (event == EVENT_ARROW_RIGHT)
return cons(named("arrow-right"), two_integers(xd,yd));
if (event == EVENT_ARROW_DOWN)
return cons(named("arrow-down"), two_integers(xd,yd));
if (event == EVENT_ARROW_LEFT)
return cons(named("arrow-left"), two_integers(xd,yd));
if (event == EVENT_FKEY)
return cons(named("fkey"), two_integers(xd,yd));
/* default */
return NIL;
}
/**
* Evaluates each rule of the list
*/
static Tree evalRuleList(Tree rules, Tree env)
{
//cerr << "evalRuleList "<< *rules << " in " << *env << endl;
if (isNil(rules)) return gGlobal->nil;
else return cons(evalRule(hd(rules), env), evalRuleList(tl(rules), env));
}
/*
* No BNF for numeric aggregates - that's defined by the caller. What
* this function does is to parse a sequence of numbers separated by the
* token specified in separator. If max is zero, any number of numbers
* will be parsed; otherwise, exactly max numbers are expected. Base
* and size tell us how to internalize the numbers once they've been
* tokenized.
*/
unsigned char *
parse_numeric_aggregate(FILE *cfile, unsigned char *buf, int *max,
int separator, int base, int size)
{
unsigned char *bufp = buf, *s = NULL;
int token, count = 0;
char *val, *t;
size_t valsize;
pair c = NULL;
if (!bufp && *max) {
bufp = malloc(*max * size / 8);
if (!bufp)
error("can't allocate space for numeric aggregate");
} else
s = bufp;
do {
if (count) {
token = peek_token(&val, cfile);
if (token != separator) {
if (!*max)
break;
if (token != RBRACE && token != LBRACE)
token = next_token(&val, cfile);
parse_warn("too few numbers.");
if (token != SEMI)
skip_to_semi(cfile);
return (NULL);
}
token = next_token(&val, cfile);
}
token = next_token(&val, cfile);
if (token == EOF) {
parse_warn("unexpected end of file");
break;
}
/* Allow NUMBER_OR_NAME if base is 16. */
if (token != NUMBER &&
(base != 16 || token != NUMBER_OR_NAME)) {
parse_warn("expecting numeric value.");
skip_to_semi(cfile);
return (NULL);
}
/*
* If we can, convert the number now; otherwise, build a
* linked list of all the numbers.
*/
if (s) {
convert_num(s, val, base, size);
s += size / 8;
} else {
valsize = strlen(val) + 1;
t = malloc(valsize);
if (!t)
error("no temp space for number.");
memcpy(t, val, valsize);
c = cons(t, c);
}
} while (++count != *max);
/* If we had to cons up a list, convert it now. */
if (c) {
bufp = malloc(count * size / 8);
if (!bufp)
error("can't allocate space for numeric aggregate.");
s = bufp + count - size / 8;
*max = count;
}
while (c) {
pair cdr = c->cdr;
convert_num(s, (char *)c->car, base, size);
s -= size / 8;
/* Free up temp space. */
free(c->car);
free(c);
c = cdr;
}
return (bufp);
}
/**
* Evaluates the list of patterns and closure the rhs
*/
static Tree evalRule(Tree rule, Tree env)
{
//cerr << "evalRule "<< *rule << " in " << *env << endl;
return cons(evalPatternList(left(rule), env), right(rule));
}
void SceneObjectCartPole::synchronousUpdate(float dt) {
if (_ticks >= _ticksPerAction || !getRenderScene()->_renderingEnabled) {
_ticks = 0;
std::array<char, _maxBatchSize> buffer;
std::array<char, 1 + 4 + 4> msg;
size_t received = 0;
size_t totalReceived = 0;
while (totalReceived < msg.size()) {
_socket->receive(buffer.data(), msg.size() - totalReceived, received);
for (int i = 0; i < received; i++)
msg[totalReceived + i] = buffer[i];
totalReceived += received;
}
if (msg[0] == 'A') { // Action
_action = pge::Vec2f(*reinterpret_cast<float*>(&msg[1]), *reinterpret_cast<float*>(&msg[5]));
}
else if (msg[0] == 'R') { // Reset
_action = pge::Vec2f(*reinterpret_cast<float*>(&msg[1]), *reinterpret_cast<float*>(&msg[5]));
reset();
}
else if (msg[0] == 'C') { // Capture + action
_action = pge::Vec2f(*reinterpret_cast<float*>(&msg[1]), *reinterpret_cast<float*>(&msg[5]));
_capture = true;
if (!getRenderScene()->_renderingEnabled) {
getRenderScene()->getRenderWindow()->setFramerateLimit(60);
getRenderScene()->getRenderWindow()->setVerticalSyncEnabled(true);
}
getRenderScene()->_renderingEnabled = true;
}
else if (msg[0] == 'S') { // Stop capture + action
_action = pge::Vec2f(*reinterpret_cast<float*>(&msg[1]), *reinterpret_cast<float*>(&msg[5]));
_capture = false;
if (!_show) {
if (getRenderScene()->_renderingEnabled) {
getRenderScene()->getRenderWindow()->setFramerateLimit(0);
getRenderScene()->getRenderWindow()->setVerticalSyncEnabled(false);
}
getRenderScene()->_renderingEnabled = false;
}
}
else if (msg[0] == 'X') { // Exit
getRenderScene()->_close = true;
}
_action.x = std::min(1.0f, std::max(-1.0f, _action.x));
_action.y = std::min(1.0f, std::max(-1.0f, _action.y));
act();
// Give state and reward (+ capture if is on)
// Observation (8 values)
std::vector<float> obs(8);
btVector3 pos = _pRigidBodyCart->getWorldTransform().getOrigin();
btVector3 vel = _pRigidBodyCart->getLinearVelocity();
btQuaternion rot = _pRigidBodyPole->getWorldTransform().getRotation();
btVector3 angleVel = _pRigidBodyPole->getAngularVelocity();
pge::Quaternion rotC = cons(rot);
pge::Vec3f rotE = rotC.getEulerAngles();
obs[0] = pos.getX();
obs[1] = pos.getZ();
obs[2] = vel.getX();
obs[3] = vel.getZ();
obs[4] = rotE.x;
obs[5] = rotE.z;
obs[6] = angleVel.getX();
obs[7] = angleVel.getZ();
// First add reward
int index = 0;
*reinterpret_cast<float*>(&buffer[index]) = _reward;
index += sizeof(float);
for (int i = 0; i < obs.size(); i++) {
*reinterpret_cast<float*>(&buffer[index]) = obs[i];
index += sizeof(float);
}
// Reset flag
*reinterpret_cast<int*>(&buffer[index]) = static_cast<int>(_doneLastFrame);
_doneLastFrame = false;
index += sizeof(int);
// Submit number of batches of _maxBatchSize
int numBatches = _capBytes->size() / _maxBatchSize + ((_capBytes->size() % _maxBatchSize) == 0 ? 0 : 1);
// No batches if not capturing
if (!_capture)
numBatches = 0;
*reinterpret_cast<int*>(&buffer[index]) = numBatches;
index += sizeof(int);
_socket->send(buffer.data(), index);
if (_capture) {
std::vector<char> reorganized(_capBytes->size());
int reorgIndex = 0;
for (int y = 0; y < getRenderScene()->_gBuffer.getHeight(); y++)
for (int x = 0; x < getRenderScene()->_gBuffer.getWidth(); x++) {
int start = 3 * (x + (getRenderScene()->_gBuffer.getHeight() - 1 - y) * getRenderScene()->_gBuffer.getWidth());
reorganized[reorgIndex++] = (*_capBytes)[start + 0];
reorganized[reorgIndex++] = (*_capBytes)[start + 1];
reorganized[reorgIndex++] = (*_capBytes)[start + 2];
}
int total = 0;
for (int i = 0; i < numBatches; i++) {
// Submit batch
size_t count = 0;
for (int j = 0; j < _maxBatchSize && total < _capBytes->size(); j++) {
buffer[j] = reorganized[total++];
count++;
}
_socket->send(buffer.data(), count);
}
}
}
else
_ticks++;
}
static Tree real_a2sb(Tree exp)
{
Tree abstr, visited, unusedEnv, localValEnv, var, name, body;
if (isClosure(exp, abstr, unusedEnv, visited, localValEnv)) {
if (isBoxIdent(abstr)) {
// special case introduced with access and components
Tree result = a2sb(eval(abstr, visited, localValEnv));
// propagate definition name property when needed
if (getDefNameProperty(exp, name)) setDefNameProperty(result, name);
return result;
} else if (isBoxAbstr(abstr, var, body)) {
// Here we have remaining abstraction that we will try to
// transform in a symbolic box by applying it to a slot
Tree slot = boxSlot(++gGlobal->gBoxSlotNumber);
stringstream s; s << boxpp(var);
setDefNameProperty(slot, s.str() ); // ajout YO
// Apply the abstraction to the slot
Tree result = boxSymbolic(slot, a2sb(eval(body, visited, pushValueDef(var, slot, localValEnv))));
// propagate definition name property when needed
if (getDefNameProperty(exp, name)) setDefNameProperty(result, name);
return result;
} else if (isBoxEnvironment(abstr)) {
return abstr;
} else {
evalerror(yyfilename, -1, "a2sb : internal error : not an abstraction inside closure", exp);
// Never reached...
return 0;
}
} else if (isBoxPatternMatcher(exp)) {
// Here we have remaining PM rules that we will try to
// transform in a symbolic box by applying it to a slot
Tree slot = boxSlot(++gGlobal->gBoxSlotNumber);
stringstream s; s << "PM" << gGlobal->gBoxSlotNumber;
setDefNameProperty(slot, s.str() );
// apply the PM rules to the slot and transfoms the result in a symbolic box
Tree result = boxSymbolic(slot, a2sb(applyList(exp, cons(slot,gGlobal->nil))));
// propagate definition name property when needed
if (getDefNameProperty(exp, name)) setDefNameProperty(result, name);
return result;
} else if (isBoxWaveform(exp)) {
// A waveform is always in Normal Form, nothing to evaluate
return exp;
} else {
// it is a constructor : transform each branches
unsigned int ar = exp->arity();
tvec B(ar);
bool modified = false;
for (unsigned int i = 0; i < ar; i++) {
Tree b = exp->branch(i);
Tree m = a2sb(b);
B[i] = m;
if (b != m) modified=true;
}
Tree r = (modified) ? CTree::make(exp->node(), B) : exp;
return r;
}
}
tl expr, val;
expr = cons(tl_s_quote, cons(a, tl_nil));
val = tl_eval_print(TL expr, env);
expr = cons(tl_s_quote, cons(cons(a, b), tl_nil));
val = tl_eval_print(TL expr, env);
expr = tl_s_cons;
val = tl_eval_print(TL expr, env);
expr = cons(tl_s_car, cons(cons(tl_s_quote, cons(expr, tl_nil)), tl_nil));
val = tl_eval_print(TL expr, env);
expr = cons(tl_s_cons,
cons(
cons(tl_s_quote, cons(a, tl_nil)),
cons(
cons(tl_s_quote, cons(b, tl_nil)),
tl_nil)));
val = tl_eval_print(TL expr, env);
expr = cons(cons(tl_s_lambda,
cons(cons(a, cons(b, tl_nil)),
cons(cons(tl_s_cons, cons(a, cons(b, tl_nil))),
tl_nil))),
cons(tl_i(1),
cons(tl_i(2),
tl_nil)));
val = tl_eval_print(TL expr, env);
/**
* repeat n times a wire
*/
static Tree nwires(int n)
{
Tree l = gGlobal->nil;
while (n--) { l = cons(boxWire(), l); }
return l;
}
OBJ vm(char *bytecode)
{
OBJ stack[1000];
int top = 0;
long fp = 0;
char *ip;
OBJ tmp;
int i;
ip = bytecode;
while(ip)
{
switch(*ip++)
{
case CONS:
stack[top-2] = cons(stack[top-1],stack[top-2]);
top--;
break;
case CAR:
stack[top-1] = car(stack[top-1]);
break;
case CDR:
stack[top-1] = cdr(stack[top-1]);
break;
case PUSH:
stack[top] = *((OBJ*)ip);
top++;
ip += sizeof(OBJ);
break;
case POP:
top--;
break;
case SET_CDR:
cdr(stack[top-1]) = stack[top-2];
stack[top - 2] = OBJ_VOID;
top--;
break;
case SET_CAR:
car(stack[top-1]) = stack[top-2];
stack[top - 2] = OBJ_VOID;
top--;
break;
case REF:
stack[top -1] = cdr(stack[top -1]);
break;
case UNINIT_REF:
if(cdr(stack[top-1]) == OBJ_VOID)
{
fprintf(stderr,"can't uninitialized variable %s.",obj_symbol_data(car(stack[top-1])));
return OBJ_NULL; /* fixme:should return a runtime error */
}
stack[top-1] = cdr(stack[top-1]);
break;
case BIND:
tmp = obj_procedure_formals(stack[top-1]);
i = top-2;
while(!nullp(tmp))
{
cdr(car(tmp)) = stack[i];
i--;
tmp = cdr(tmp);
}
stack[i+1] = stack[top-1];
top = i+2;
break;
case EQ:
if(eq(stack[top-1],stack[top-2]))
stack[top-2] = OBJ_TRUE;
else
stack[top-2] = OBJ_FALSE;
top--;
break;
case ADD:
stack[top-2] = add(stack[top-1],stack[top-2]);
top--;
break;
case MUL:
stack[top-2] = mul(stack[top-1],stack[top-2]);
top--;
break;
case SUB:
stack[top-2] = sub(stack[top-1],stack[top-2]);
top--;
break;
/* case DIV: */
/* stack[top-2] = div(stack[top-1],stack[top-2]); */
/* top--; */
/* break; */
case TYPE:
switch(*ip)
{
case OBJ_BOOLEAN:
stack[top-1] = obj_make_boolean(obj_booleanp(stack[top-1]));
break;
case OBJ_SYMBOL:
stack[top-1] = obj_make_boolean(obj_symbolp(stack[top-1]));
break;
case OBJ_CHAR:
stack[top-1] = obj_make_boolean(obj_charp(stack[top-1]));
break;
case OBJ_VECTOR:
stack[top-1] = obj_make_boolean(obj_vectorp(stack[top-1]));
break;
case OBJ_PROCEDURE:
stack[top-1] = obj_make_boolean(obj_primitivep(stack[top-1]) || obj_procedurep(stack[top-1]));
break;
case OBJ_PAIR:
stack[top-1] = obj_make_boolean(obj_pairp(stack[top-1]));
break;
case OBJ_NUMBER:
stack[top-1] = obj_make_boolean(obj_numberp(stack[top-1]));
break;
case OBJ_STRING:
stack[top-1] = obj_make_boolean(obj_stringp(stack[top-1]));
break;
// case OBJ_PORT:
}
ip += sizeof(OBJ);
break;
case JUMP:
ip = *((char**)ip);
break;
case JUMP_UNLESS:
if(stack[top-1] == OBJ_FALSE)
ip = *((char**)ip);
else
ip += sizeof(char*);
break;
case CALL:
stack[top] = ip;
top++;
stack[top] = fp;
top++;
fp = top-3;
ip = obj_string_data(obj_procedure_code(stack[fp]));
break;
case TAIL_CALL:
ip = obj_string_data(obj_procedure_code(stack[top-1]));
top = fp+3;
break;
case RET:
ip = (char*)(stack[fp+1]);
stack[fp] = stack[top-1];
top = fp+1;
fp = (long)stack[fp+2];
break;
case GT:
if(obj_numberp(stack[top-1]) && obj_numberp(stack[top-2]))
{
stack[top-2] = obj_make_boolean(obj_number_data(stack[top-1]) > obj_number_data(stack[top-2]));
}
top--;
break;
case FC1:
stack[top-1] = (*((fn1_t*)ip))(stack[top-1]);
ip += sizeof(OBJ);
break;
case FC2:
stack[top-2] = (*((fn2_t*)ip))(stack[top-1],stack[top-2]);
top--;
ip += sizeof(OBJ);
break;
case DONE:
goto out;
default:
printf("error instruction!\n");
goto error;
}
}
error:
printf("error instruction!\n");
return OBJ_NULL;
out:
return stack[top-1];
}
/**
* Apply a function to a list of arguments.
* Apply a function F to a list of arguments (a,b,c,...).
* F can be either a closure over an abstraction, or a
* pattern matcher. If it is not the case then we have :
* F(a,b,c,...) ==> (a,b,c,...):F
*
* @param fun the function to apply
* @param larg the list of arguments
* @return the resulting expression in normal form
*/
static Tree applyList (Tree fun, Tree larg)
{
Tree abstr;
Tree globalDefEnv;
Tree visited;
Tree localValEnv;
Tree envList;
Tree originalRules;
Tree revParamList;
Tree id;
Tree body;
Automaton* automat;
int state;
prim2 p2;
//cerr << "applyList (" << *fun << ", " << *larg << ")" << endl;
if (isNil(larg)) return fun;
if (isBoxError(fun) || isBoxError(larg)) {
return boxError();
}
if (isBoxPatternMatcher(fun, automat, state, envList, originalRules, revParamList)) {
Tree result;
int state2;
vector<Tree> envVect;
list2vec(envList, envVect);
//cerr << "applyList/apply_pattern_matcher(" << automat << "," << state << "," << *hd(larg) << ")" << endl;
state2 = apply_pattern_matcher(automat, state, hd(larg), result, envVect);
//cerr << "state2 = " << state2 << "; result = " << *result << endl;
if (state2 >= 0 && isNil(result)) {
// we need to continue the pattern matching
return applyList(
boxPatternMatcher(automat, state2, vec2list(envVect), originalRules, cons(hd(larg),revParamList)),
tl(larg) );
} else if (state2 < 0) {
stringstream error;
error << "ERROR : pattern matching failed, no rule of " << boxpp(boxCase(originalRules))
<< " matches argument list " << boxpp(reverse(cons(hd(larg), revParamList))) << endl;
throw faustexception(error.str());
} else {
// Pattern Matching was succesful
// the result is a closure that we need to evaluate.
if (isClosure(result, body, globalDefEnv, visited, localValEnv)) {
// why ??? return simplifyPattern(eval(body, nil, localValEnv));
//return eval(body, nil, localValEnv);
return applyList(eval(body, gGlobal->nil, localValEnv), tl(larg));
} else {
cerr << "wrong result from pattern matching (not a closure) : " << boxpp(result) << endl;
return boxError();
}
}
}
if (!isClosure(fun, abstr, globalDefEnv, visited, localValEnv)) {
// principle : f(a,b,c,...) ==> (a,b,c,...):f
int ins, outs;
// check arity of function
Tree efun = a2sb(fun);
//cerr << "TRACEPOINT 1 : " << boxpp(efun) << endl;
if (!getBoxType(efun, &ins, &outs)) { // on laisse comme ca pour le moment
// we can't determine the input arity of the expression
// hope for the best
return boxSeq(larg2par(larg), fun);
}
// check arity of arg list
if (!boxlistOutputs(larg, &outs)) {
// we don't know yet the output arity of larg. Therefore we can't
// do any arity checking nor add _ to reach the required number of arguments
// cerr << "warning : can't infere the type of : " << boxpp(larg) << endl;
return boxSeq(larg2par(larg), fun);
}
if (outs > ins) {
stringstream error;
error << "too much arguments : " << outs << ", instead of : " << ins << endl;
error << "when applying : " << boxpp(fun) << endl
<< "to : " << boxpp(larg) << endl;
throw faustexception(error.str());
}
if ((outs == 1)
&& (( isBoxPrim2(fun, &p2) && (p2 != sigPrefix))
|| (getUserData(fun) && ((xtended*)getUserData(fun))->isSpecialInfix()))) {
// special case : /(3) ==> _,3 : /
Tree larg2 = concat(nwires(ins-outs), larg);
return boxSeq(larg2par(larg2), fun);
} else {
Tree larg2 = concat(larg, nwires(ins-outs));
return boxSeq(larg2par(larg2), fun);
}
}
if (isBoxEnvironment(abstr)) {
evalerrorbox(yyfilename, -1, "an environment can't be used as a function", fun);
}
if (!isBoxAbstr(abstr, id, body)) {
evalerror(yyfilename, -1, "(internal) not an abstraction inside closure", fun);
}
// try to synthetise a name from the function name and the argument name
{
Tree arg = eval(hd(larg), visited, localValEnv);
Tree narg; if ( isBoxNumeric(arg,narg) ) { arg = narg; }
Tree f = eval(body, visited, pushValueDef(id, arg, localValEnv));
Tree fname;
if (getDefNameProperty(fun, fname)) {
stringstream s; s << tree2str(fname); if (!gGlobal->gSimpleNames) s << "(" << boxpp(arg) << ")";
setDefNameProperty(f, s.str());
}
return applyList(f, tl(larg));
}
}
public: Val AddReq(Val ty)
{ ASSERT(nil != ty); m_reqs = cons(ty, m_reqs); return ty; }
static at *
two_integers(int i1, int i2)
{
return cons(NEW_NUMBER(i1), cons(NEW_NUMBER(i2), NIL));
}
int rscheme_std_main( int argc, const char **argv,
struct module_descr **modules,
const char *default_image )
{
obj start, args, rc;
const char *system_file = NULL;
int i = 1;
rs_bool verbose = YES;
rs_bool is_script = NO;
init_dynamic_link( argv[0] ); /* some systems need this */
for (i=1; i<argc && argv[i][0] == (char)'-'; i++)
{
if (strcmp(argv[i],"-image") == 0)
{
if (i+1 >= argc)
goto miss_arg;
system_file = argv[++i];
}
else if (strcmp(argv[i],"--version") == 0)
{
puts( RSCHEME_VERSION );
return 0;
}
else if (strcmp(argv[i],"--install") == 0)
{
puts( rs_install_dir );
return 0;
}
else if (strcmp(argv[i],"-qimage") == 0)
{
if (i+1 >= argc)
goto miss_arg;
system_file = argv[++i];
verbose = NO;
}
else if (strcmp(argv[i],"-bcitrace") == 0)
{
if (bci_trace_flag >= 0)
bci_trace_flag = 1;
else
goto not_comp;
}
else if (strcmp(argv[i],"-stepdump") == 0)
{
#ifdef STEP_DUMP
do_step_dump = 1;
#else
goto not_comp;
#endif
}
else if (strcmp(argv[i],"-q") == 0)
{
verbose = NO;
}
else if (strcmp(argv[i],"-script") == 0)
{
verbose = NO;
is_script = YES;
}
#ifdef RECORD_CALL_CHAIN
else if (strcmp(argv[i],"-abt") == 0)
{
extern rs_bool do_record_call_chain;
do_record_call_chain = YES;
}
#endif
else
break;
}
if (!system_file)
system_file = find_system_image( argv[0], default_image );
if (!system_file)
{
fprintf( stderr, "%s: could not find system image\n", argv[0] );
return 1; /* boot failed */
}
start = init_scheme( argc, argv, system_file,
verbose,
modules );
if (EQ(start,FALSE_OBJ))
{
fprintf( stderr, "%s: initialization from %s failed\n",
argv[0], system_file );
return 1;
}
args = NIL_OBJ;
while (argc > i)
args = cons( make_string( argv[--argc] ), args );
rc = call_scheme( start, 3,
args,
rb_to_bo(verbose),
rb_to_bo(is_script) );
if (truish(rc))
return 0;
return 1;
miss_arg:
fprintf( stderr, "missing arg to `%s'\n", argv[i] );
return 2;
not_comp:
fprintf( stderr, "system not compiled to support `%s'\n", argv[i] );
return 2;
}
siglist realPropagate (Tree slotenv, Tree path, Tree box, const siglist& lsig)
{
int i;
double r;
prim0 p0;
prim1 p1;
prim2 p2;
prim3 p3;
prim4 p4;
prim5 p5;
Tree t1, t2, ff, label, cur, min, max, step, type, name, file, slot, body, chan;
tvec wf;
xtended* xt = (xtended*)getUserData(box);
// Extended Primitives
if (xt) {
faustassert(lsig.size() == xt->arity());
return makeList(xt->computeSigOutput(lsig));
}
// Numbers and Constants
else if (isBoxInt(box, &i)) {
faustassert(lsig.size()==0);
return makeList(sigInt(i));
}
else if (isBoxReal(box, &r)) {
faustassert(lsig.size()==0);
return makeList(sigReal(r));
}
// A Waveform has two outputs it size and a period signal representing its content
else if (isBoxWaveform(box)) {
faustassert(lsig.size()==0);
const tvec br = box->branches();
return listConcat(makeList(sigInt(int(br.size()))), makeList(sigWaveform(br)));
}
else if (isBoxFConst(box, type, name, file)) {
faustassert(lsig.size()==0);
return makeList(sigFConst(type, name, file));
}
else if (isBoxFVar(box, type, name, file)) {
faustassert(lsig.size()==0);
return makeList(sigFVar(type, name, file));
}
// Wire and Cut
else if (isBoxCut(box)) {
faustassert(lsig.size()==1);
return siglist();
}
else if (isBoxWire(box)) {
faustassert(lsig.size()==1);
return lsig;
}
// Slots and Symbolic Boxes
else if (isBoxSlot(box)) {
Tree sig;
faustassert(lsig.size()==0);
if (!searchEnv(box,sig,slotenv)) {
// test YO simplification des diagrames
//fprintf(stderr, "propagate : internal error (slot undefined)\n");
sig = sigInput(++gGlobal->gDummyInput);
}
return makeList(sig);
}
else if (isBoxSymbolic(box, slot, body)) {
faustassert(lsig.size()>0);
return propagate(pushEnv(slot,lsig[0],slotenv), path, body, listRange(lsig, 1, (int)lsig.size()));
}
// Primitives
else if (isBoxPrim0(box, &p0)) {
faustassert(lsig.size()==0);
return makeList(p0());
}
else if (isBoxPrim1(box, &p1)) {
faustassert(lsig.size()==1);
return makeList(p1(lsig[0]));
}
else if (isBoxPrim2(box, &p2)) {
// printf("prim2 recoit : "); print(lsig); printf("\n");
faustassert(lsig.size()==2);
if (p2 == &sigEnable) {
if (gGlobal->gEnableFlag) {
// special case for sigEnable that requires a transformation
// enable(X,Y) -> sigEnable(X*Y, Y>0)
return makeList(sigEnable( sigMul(lsig[0],lsig[1]), sigGT(lsig[1],sigReal(0.0))));
} else {
// We gEnableFlag is false we replace enable by a simple multiplication
return makeList(sigMul(lsig[0],lsig[1]));
}
} else if (p2 == &sigControl) {
if (gGlobal->gEnableFlag) {
// special case for sigEnable that requires a transformation
// enable(X,Y) -> sigEnable(X*Y, Y>0)
return makeList(sigEnable( lsig[0], lsig[1]));
} else {
// We gEnableFlag is false we replace control by identity function
return makeList(lsig[0]);
}
}
return makeList( p2(lsig[0],lsig[1]) );
}
else if (isBoxPrim3(box, &p3)) {
faustassert(lsig.size()==3);
return makeList(p3(lsig[0],lsig[1],lsig[2]));
}
else if (isBoxPrim4(box, &p4)) {
faustassert(lsig.size()==4);
return makeList(p4(lsig[0],lsig[1],lsig[2],lsig[3]));
}
else if (isBoxPrim5(box, &p5)) {
faustassert(lsig.size()==5);
return makeList(p5(lsig[0],lsig[1],lsig[2],lsig[3],lsig[4]));
}
else if (isBoxFFun(box, ff)) {
//cerr << "propagate en boxFFun of arity " << ffarity(ff) << endl;
faustassert(int(lsig.size())==ffarity(ff));
return makeList(sigFFun(ff, listConvert(lsig)));
}
// User Interface Widgets
else if (isBoxButton(box, label)) {
faustassert(lsig.size()==0);
return makeList(sigButton(normalizePath(cons(label, path))));
}
else if (isBoxCheckbox(box, label)) {
faustassert(lsig.size()==0);
return makeList(sigCheckbox(normalizePath(cons(label, path))));
}
else if (isBoxVSlider(box, label, cur, min, max, step)) {
faustassert(lsig.size()==0);
return makeList(sigVSlider(normalizePath(cons(label, path)), cur, min, max, step));
}
else if (isBoxHSlider(box, label, cur, min, max, step)) {
faustassert(lsig.size()==0);
return makeList(sigHSlider(normalizePath(cons(label, path)), cur, min, max, step));
}
else if (isBoxNumEntry(box, label, cur, min, max, step)) {
faustassert(lsig.size()==0);
return makeList(sigNumEntry(normalizePath(cons(label, path)), cur, min, max, step));
}
else if (isBoxVBargraph(box, label, min, max)) {
faustassert(lsig.size()==1);
return makeList(sigVBargraph(normalizePath(cons(label, path)), min, max, lsig[0]));
}
else if (isBoxHBargraph(box, label, min, max)) {
faustassert(lsig.size()==1);
return makeList(sigHBargraph(normalizePath(cons(label, path)), min, max, lsig[0]));
}
else if (isBoxSoundfile(box, label, chan)) {
faustassert(lsig.size()==1);
Tree fullpath = normalizePath(cons(label, path));
Tree soundfile = sigSoundfile(fullpath);
int c = tree2int(chan);
siglist lsig2(c+3);
lsig2[0] = sigSoundfileLength(soundfile);
lsig2[1] = sigSoundfileRate(soundfile);
lsig2[2] = sigSoundfileChannels(soundfile);
// compute bound limited read index : int(max(0, min(ridx,length-1)))
Tree ridx = sigIntCast(tree(gGlobal->gMaxPrim->symbol(), sigInt(0), tree(gGlobal->gMinPrim->symbol(), lsig[0], sigAdd(lsig2[0],sigInt(-1)))));
for (int i = 0; i<c; i++) {
lsig2[i+3] = sigSoundfileBuffer(soundfile, sigInt(i), ridx);
}
return lsig2;
}
// User Interface Groups
else if (isBoxVGroup(box, label, t1)) {
return propagate(slotenv,cons(cons(tree(0),label), path), t1, lsig);
}
else if (isBoxHGroup(box, label, t1)) {
return propagate(slotenv, cons(cons(tree(1),label), path), t1, lsig);
}
else if (isBoxTGroup(box, label, t1)) {
return propagate(slotenv, cons(cons(tree(2),label), path), t1, lsig);
}
// Block Diagram Composition Algebra
else if (isBoxSeq(box, t1, t2)) {
int in1, out1, in2, out2;
getBoxType(t1, &in1, &out1);
getBoxType(t2, &in2, &out2);
faustassert(out1==in2);
if (out1 == in2) {
return propagate(slotenv, path, t2, propagate(slotenv, path,t1,lsig));
} else if (out1 > in2) {
siglist lr = propagate(slotenv, path, t1,lsig);
return listConcat(propagate(slotenv, path, t2, listRange(lr, 0, in2)), listRange(lr, in2, out1));
} else {
return propagate(slotenv, path, t2, listConcat( propagate(slotenv, path, t1, listRange(lsig,0,in1)), listRange(lsig,in1,in1+in2-out1)));
}
}
else if (isBoxPar(box, t1, t2)) {
int in1, out1, in2, out2;
getBoxType(t1, &in1, &out1);
getBoxType(t2, &in2, &out2);
return listConcat(propagate(slotenv, path, t1, listRange(lsig, 0, in1)),
propagate(slotenv, path, t2, listRange(lsig, in1, in1+in2)));
}
else if (isBoxSplit(box, t1, t2)) {
int in1, out1, in2, out2;
getBoxType(t1, &in1, &out1);
getBoxType(t2, &in2, &out2);
siglist l1 = propagate(slotenv, path, t1, lsig);
siglist l2 = split(l1, in2);
return propagate(slotenv, path, t2, l2);
}
else if (isBoxMerge(box, t1, t2)) {
int in1, out1, in2, out2;
getBoxType(t1, &in1, &out1);
getBoxType(t2, &in2, &out2);
siglist l1 = propagate(slotenv, path, t1, lsig);
siglist l2 = mix(l1, in2);
return propagate(slotenv, path, t2, l2);
}
else if (isBoxRec(box, t1, t2)) {
// Bug Corrected
int in1, out1, in2, out2;
getBoxType(t1, &in1, &out1);
getBoxType(t2, &in2, &out2);
Tree slotenv2 = lift(slotenv); // the environment must also be lifted
siglist l0 = makeMemSigProjList(ref(1), in2);
siglist l1 = propagate(slotenv2, path, t2, l0);
siglist l2 = propagate(slotenv2, path, t1, listConcat(l1,listLift(lsig)));
siglist l3 = (gGlobal->gFTZMode > 0) ? wrapWithFTZ(l2) : l2;
Tree g = rec(listConvert(l3));
return makeSigProjList(g, out1);
}
stringstream error;
error << "ERROR in file " << __FILE__ << ':' << __LINE__ << ", unrecognised box expression : " << boxpp(box) << endl;
throw faustexception(error.str());
return siglist();
}
