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(); }