RML_END_LABEL
RML_BEGIN_LABEL(External__strtok)
{
char *s;
char *delimit = RML_STRINGDATA(rmlA1);
char *str = strdup(RML_STRINGDATA(rmlA0));
void * res = (void*)mk_nil();
s=strtok(str,delimit);
if (s == NULL)
{
/* adrpo added 2004-10-27 */
free(str);
rmlA0=res; RML_TAILCALLK(rmlFC);
}
res = (void*)mk_cons(mk_scon(s),res);
while (s=strtok(NULL,delimit))
{
res = (void*)mk_cons(mk_scon(s),res);
}
rmlA0=res;
/* adrpo added 2004-10-27 */
free(str);
/* adrpo changed 2004-10-29
rml_prim_once(RML__list_5freverse);
RML_TAILCALLK(rmlSC);
*/
RML_TAILCALLQ(RML__list_5freverse,1);
}
sexpr_t* eval_list(sexpr_t* list, sexpr_t** env, sexpr_list_t* roots, error_t** error)
{
sexpr_t* head = NULL;
sexpr_t *current_e = NULL;
sexpr_t* result;
sexpr_t* current = list;
while(current != NULL) {
result = eval(CAR(current), env, roots, error);
if(*error != NULL) {
return NULL;
}
if(head == NULL) {
current_e = mk_cons(result, NULL);
head = current_e;
} else {
SET_CDR(current_e, mk_cons(result, NULL));
current_e = CDR(current_e);
}
roots = cons_to_roots_list(roots, current_e);
current = CDR(current);
}
return head;
}
static value_t cons_(value_t *pcar, value_t *pcdr)
{
value_t c = mk_cons();
car_(c) = *pcar;
cdr_(c) = *pcdr;
return c;
}
value_t *cons(value_t *pcar, value_t *pcdr)
{
value_t c = mk_cons();
car_(c) = *pcar;
cdr_(c) = *pcdr;
PUSH(c);
return &Stack[SP-1];
}
DataField getData(const char *varname,const char *filename, unsigned int size, SimulationResult_Globals* srg)
{
DataField res;
void *cmpvar,*dataset,*lst,*datasetBackup;
double *newvars;
double d;
unsigned int i;
unsigned int ncmpvars = 0;
res.n = 0;
res.data = NULL;
/* fprintf(stderr, "getData of Var: %s from file %s\n", varname,filename); */
cmpvar = mk_nil();
cmpvar = mk_cons(mk_scon(varname),cmpvar);
dataset = SimulationResultsImpl__readDataset(filename,cmpvar,size,srg);
if (dataset==NULL) {
/* fprintf(stderr, "getData of Var: %s failed!\n",varname); */
return res;
}
/* fprintf(stderr, "Data of Var: %s\n", varname);
First calculate the length of the matrix */
datasetBackup = dataset;
while (RML_NILHDR != RML_GETHDR(dataset)) {
lst = RML_CAR(dataset);
while (RML_NILHDR != RML_GETHDR(lst)) {
res.n++;
lst = RML_CDR(lst);
}
dataset = RML_CDR(dataset);
}
if (res.n == 0) return res;
/* The allocate and read the values */
dataset = datasetBackup;
i = res.n;
res.data = (double*) malloc(sizeof(double)*res.n);
while (RML_NILHDR != RML_GETHDR(dataset)) {
lst = RML_CAR(dataset);
while (RML_NILHDR != RML_GETHDR(lst)) {
res.data[--i] = rml_prim_get_real(RML_CAR(lst));
lst = RML_CDR(lst);
}
dataset = RML_CDR(dataset);
}
assert(i == 0);
/* for (i=0;i<res.n;i++)
fprintf(stderr, "%d: %.6g\n", i, res.data[i]); */
return res;
}
static value_t relocate(value_t v)
{
value_t a, d, nc;
if (!iscons(v))
return v;
if (car_(v) == UNBOUND)
return cdr_(v);
nc = mk_cons();
a = car_(v);
d = cdr_(v);
car_(v) = UNBOUND;
cdr_(v) = nc;
car_(nc) = relocate(a);
cdr_(nc) = relocate(d);
return nc;
}
RML_END_LABEL
RML_BEGIN_LABEL(BackendDAEEXT__getEqnsforIndexReduction)
{
int i=0;
int *eqns = (int*) malloc((n+1) * sizeof(int));
int eqns_size=0;
rmlA0 = mk_nil();
if ((match != NULL) && (row_match != NULL) && (eqns != NULL)) {
eqns_size = getEqnsForIndexReduction(col_ptrs,col_ids,match,row_match,n,m,eqns);
}
for (i = 0; i < eqns_size; i++) {
rmlA0 = mk_cons(mk_icon(eqns[i]+1),rmlA0);
}
if (eqns) free(eqns);
RML_TAILCALLK(rmlSC);
}
// build a list of conses. this is complicated by the fact that all conses
// can move whenever a new cons is allocated. we have to refer to every cons
// through a handle to a relocatable pointer (i.e. a pointer on the stack).
static void read_list(value_t *pval, value_t label)
{
value_t c, *pc;
u_int32_t t;
PUSH(NIL);
pc = &Stack[SP-1]; // to keep track of current cons cell
t = peek();
while (t != TOK_CLOSE) {
if (ios_eof(F))
lerror(ParseError, "read: unexpected end of input");
c = mk_cons(); car_(c) = cdr_(c) = NIL;
if (iscons(*pc)) {
cdr_(*pc) = c;
}
else {
*pval = c;
if (label != UNBOUND)
ptrhash_put(&readstate->backrefs, (void*)label, (void*)c);
}
*pc = c;
c = do_read_sexpr(UNBOUND); // must be on separate lines due to
car_(*pc) = c; // undefined evaluation order
t = peek();
if (t == TOK_DOT) {
take();
c = do_read_sexpr(UNBOUND);
cdr_(*pc) = c;
t = peek();
if (ios_eof(F))
lerror(ParseError, "read: unexpected end of input");
if (t != TOK_CLOSE)
lerror(ParseError, "read: expected ')'");
}
}
take();
(void)POP();
}
// build a list of conses. this is complicated by the fact that all conses
// can move whenever a new cons is allocated. we have to refer to every cons
// through a handle to a relocatable pointer (i.e. a pointer on the stack).
static void read_list(FILE *f, value_t *pval)
{
value_t c, *pc;
u_int32_t t;
PUSH(NIL);
pc = &Stack[SP-1]; // to keep track of current cons cell
t = peek(f);
while (t != TOK_CLOSE) {
if (feof(f))
lerror("read: error: unexpected end of input\n");
c = mk_cons();
car_(c) = cdr_(c) = NIL;
if (iscons(*pc))
cdr_(*pc) = c;
else
*pval = c;
*pc = c;
c = read_sexpr(f); // must be on separate lines due to undefined
car_(*pc) = c; // evaluation order
t = peek(f);
if (t == TOK_DOT) {
take();
c = read_sexpr(f);
cdr_(*pc) = c;
t = peek(f);
if (feof(f))
lerror("read: error: unexpected end of input\n");
if (t != TOK_CLOSE)
lerror("read: error: expected ')'\n");
}
}
take();
POP();
}
sexpr_t* eval(sexpr_t* sexpr, sexpr_t** env, sexpr_list_t* roots, error_t** error)
{
if(sexpr == NULL) {
return interp.nil_sym;
}
/* printf("[eval]\n"); */
/* print_sexpr(sexpr); */
/* printf("\n"); */
roots = cons_to_roots_list(roots, sexpr);
gc_collect(roots);
if(ATOM(sexpr)) {
if(SYM(sexpr)) {
if(interp.t_sym == sexpr) {
return interp.t_sym;
}
if(interp.nil_sym == sexpr) {
return interp.nil_sym;
}
sexpr_t* val = assoc(sexpr, *env);
if(val == NULL) {
*error = mk_error("Undefined symbol", SYM_VAL(sexpr));
}
return val;
}
if(INT(sexpr)) {
return sexpr;
}
} else if(ATOM(CAR(sexpr))) {
if(SYM(CAR(sexpr))) {
// quote
if(interp.quote_sym == CAR(sexpr)) {
if(CDR(sexpr) == NULL) {
*error = mk_error("Missing quote argument", "");
return NULL;
}
if(CDR(CDR(sexpr)) != NULL) {
*error = mk_error("Too many arguments for quote", "");
return NULL;
}
return CAR(CDR(sexpr));
}
// atom
if(interp.atom_sym == CAR(sexpr)) {
if(ATOM(eval(CAR(CDR(sexpr)), env, roots, error))) {
return interp.t_sym;
}
return interp.nil_sym;
}
// eq
if(interp.eq_sym == CAR(sexpr)) {
// TODO check nb args
sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error);
if(*error != NULL) {
return NULL;
}
roots = cons_to_roots_list(roots, e1);
sexpr_t* e2 = eval(CAR(CDR(CDR(sexpr))), env, roots, error);
if(*error != NULL) {
return NULL;
}
if(INT(e1) && INT(e2)) {
if(INT_VAL(e1) == INT_VAL(e2)) {
return interp.t_sym;
}
return interp.nil_sym;
}
if(e1 == e2) {
return interp.t_sym;
}
return interp.nil_sym;
}
// if
if(interp.if_sym == CAR(sexpr)) {
sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error);
if(*error != NULL) {
return NULL;
}
if(e1 == interp.nil_sym) {
return eval(CAR(CDR(CDR(CDR(sexpr)))), env, roots, error);
} else {
return eval(CAR(CDR(CDR(sexpr))), env, roots, error);
}
}
// car
if(interp.car_sym == CAR(sexpr)) {
sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error);
if(*error != NULL) {
return NULL;
}
if(e1 == interp.nil_sym) {
return interp.nil_sym;
}
return CAR(e1);
}
// cdr
if(interp.cdr_sym == CAR(sexpr)) {
sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error);
if(*error != NULL) {
return NULL;
}
if(e1 == interp.nil_sym) {
return interp.nil_sym;
}
sexpr_t *res = CDR(e1);
if(res == NULL) {
return interp.nil_sym;
}
return res;
}
// +
if(interp.plus_sym == CAR(sexpr)) {
sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error);
if(*error != NULL) {
return NULL;
}
roots = cons_to_roots_list(roots, e1);
sexpr_t* e2 = eval(CAR(CDR(CDR(sexpr))), env, roots, error);
if(*error != NULL) {
return NULL;
}
if(INT(e1) && INT(e2)) {
return mk_int(INT_VAL(e1) + INT_VAL(e2));
}
*error = mk_error("Arguments for '+' are not integers", "");
return NULL;
}
// -
if(interp.minus_sym == CAR(sexpr)) {
sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error);
if(*error != NULL) {
return NULL;
}
roots = cons_to_roots_list(roots, e1);
sexpr_t* e2 = eval(CAR(CDR(CDR(sexpr))), env, roots, error);
if(*error != NULL) {
return NULL;
}
if(INT(e1) && INT(e2)) {
return mk_int(INT_VAL(e1) - INT_VAL(e2));
}
*error = mk_error("Arguments for '-' are not integers", "");
return NULL;
}
if(interp.mul_sym == CAR(sexpr)) {
sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error);
if(*error != NULL) {
return NULL;
}
roots = cons_to_roots_list(roots, sexpr);
sexpr_t* e2 = eval(CAR(CDR(CDR(sexpr))), env, roots, error);
if(*error != NULL) {
return NULL;
}
if(INT(e1) && INT(e2)) {
return mk_int(INT_VAL(e1) * INT_VAL(e2));
}
*error = mk_error("Arguments for '*' are not integers", "");
return NULL;
}
// cons
if(interp.cons_sym == CAR(sexpr)) {
sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error);
if(*error != NULL) {
return NULL;
}
roots = cons_to_roots_list(roots, e1);
sexpr_t* e2 = eval(CAR(CDR(CDR(sexpr))), env, roots, error);
if(*error != NULL) {
return NULL;
}
return mk_cons(e1 == interp.nil_sym ? NULL : e1, e2 == interp.nil_sym ? NULL : e2);
}
// def
if(interp.def_sym == CAR(sexpr)) {
sexpr_t* arg = CAR(CDR(CDR(sexpr)));
roots = cons_to_roots_list(roots, arg);
sexpr_t* val = eval(arg, env, roots, error);
if(*error != NULL) {
return NULL;
}
*env = mk_cons(mk_cons(intern(SYM_VAL(CAR(CDR(sexpr)))), val), *env);
return val;
}
// print
if(interp.print_sym == CAR(sexpr)) {
sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error);
if(*error != NULL) {
return NULL;
}
print_sexpr(e1);
printf("\n");
return e1;
}
// fn
if(interp.fn_sym == CAR(sexpr)) {
return mk_fn(sexpr, *env);
}
// macro
if(interp.macro_sym == CAR(sexpr)) {
return mk_macro(sexpr);
}
//eval
if(interp.eval_sym == CAR(sexpr)) {
sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error);
if(*error != NULL) {
return NULL;
}
roots = cons_to_roots_list(roots, e1);
return eval(e1, env, roots, error);
}
// else resolves first variable
sexpr_t* fn = eval(CAR(sexpr), env, roots, error);
if(*error != NULL) {
return NULL;
}
// eval fn
if(FN(fn)) {
sexpr_t* fn_code = CAR(CDR(CDR(CAR(fn))));
sexpr_t* captured_env = CDR(fn);
sexpr_t* arguments = eval_list(CDR(sexpr), env, roots, error);
if(*error != NULL) {
return NULL;
}
sexpr_t* pairs = pair(CAR(CDR(CAR(fn))), arguments);
sexpr_t* eval_env = append(pairs, captured_env);
// append the function itself to the env, roots, for recursive calls
eval_env = mk_cons(mk_cons(CAR(sexpr), fn), eval_env);
/* printf("fn code=\n"); */
/* print_sexpr(fn_code); */
/* printf("\n"); */
roots = cons_to_roots_list(roots, eval_env);
return eval(fn_code, &eval_env, roots, error);
}
// eval macro
if(MACRO(fn)) {
sexpr_t* macro_code = CAR(CDR(CDR(CAR(fn))));
sexpr_t* pairs = pair(CAR(CDR(CAR(fn))), CDR(sexpr));
sexpr_t* eval_env = append(pairs, *env);
roots = cons_to_roots_list(roots, eval_env);
sexpr_t* transformed_code = eval(macro_code, &eval_env, roots, error);
if(*error != NULL) {
return NULL;
}
return eval(transformed_code, env, roots, error);
}
// else primitives
sexpr_t* arguments = eval_list(CDR(sexpr), env, roots, error);
if(*error != NULL) {
return NULL;
}
sexpr_t* to_eval = mk_cons(fn, arguments);
return eval(to_eval, env, roots, error);
}
} else if(CAR(CAR(sexpr)) == interp.fn_sym) {
// executes an anonymous function
sexpr_t* fn = CAR(sexpr);
sexpr_t* fn_code = CAR(CDR(CDR(fn)));
sexpr_t* arguments = eval_list(CDR(sexpr), env, roots, error);
if(*error != NULL) {
return NULL;
}
sexpr_t* l = pair(CAR(CDR(fn)), arguments);
l = append(l, *env);
roots = cons_to_roots_list(roots, l);
return eval(fn_code, &l, roots, error);
}
print_sexpr(sexpr);
printf("\n");
*error = mk_error("Invalid expression", "");
return NULL;
}
value_t eval_sexpr(value_t e, value_t *penv)
{
value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
value_t *rest;
cons_t *c;
symbol_t *sym;
u_int32_t saveSP;
int i, nargs, noeval=0;
number_t s, n;
eval_top:
if (issymbol(e)) {
sym = (symbol_t*)ptr(e);
if (sym->constant != UNBOUND) return sym->constant;
v = *penv;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == e)
return cdr_(bind);
v = cdr_(v);
}
if ((v = sym->binding) == UNBOUND)
lerror("eval: error: variable %s has no value\n", sym->name);
return v;
}
if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
lerror("eval: error: stack overflow\n");
saveSP = SP;
PUSH(e);
PUSH(*penv);
f = eval(car_(e), penv);
*penv = Stack[saveSP+1];
if (isbuiltin(f)) {
// handle builtin function
if (!isspecial(f)) {
// evaluate argument list, placing arguments on stack
v = Stack[saveSP] = cdr_(Stack[saveSP]);
while (iscons(v)) {
v = eval(car_(v), penv);
*penv = Stack[saveSP+1];
PUSH(v);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
}
apply_builtin:
nargs = SP - saveSP - 2;
switch (intval(f)) {
// special forms
case F_QUOTE:
v = cdr_(Stack[saveSP]);
if (!iscons(v))
lerror("quote: error: expected argument\n");
v = car_(v);
break;
case F_MACRO:
case F_LAMBDA:
v = Stack[saveSP];
if (*penv != NIL) {
// build a closure (lambda args body . env)
v = cdr_(v);
PUSH(car(v));
argsyms = &Stack[SP-1];
PUSH(car(cdr_(v)));
body = &Stack[SP-1];
v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
cons(argsyms, cons(body, penv)));
}
break;
case F_LABEL:
v = Stack[saveSP];
if (*penv != NIL) {
v = cdr_(v);
PUSH(car(v)); // name
pv = &Stack[SP-1];
PUSH(car(cdr_(v))); // function
body = &Stack[SP-1];
*body = eval(*body, penv); // evaluate lambda
v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
}
break;
case F_IF:
v = car(cdr_(Stack[saveSP]));
if (eval(v, penv) != NIL)
v = car(cdr_(cdr_(Stack[saveSP])));
else
v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
tail_eval(v, Stack[saveSP+1]);
break;
case F_COND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
v = eval(c->car, penv);
*penv = Stack[saveSP+1];
if (v != NIL) {
*pv = cdr_(car_(*pv));
// evaluate body forms
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
}
*pv = cdr_(*pv);
}
break;
case F_AND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = T;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv), penv)) == NIL) {
SP = saveSP;
return NIL;
}
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
case F_OR:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv), penv)) != NIL) {
SP = saveSP;
return v;
}
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
case F_WHILE:
PUSH(cdr(cdr_(Stack[saveSP])));
body = &Stack[SP-1];
PUSH(*body);
Stack[saveSP] = car_(cdr_(Stack[saveSP]));
value_t *cond = &Stack[saveSP];
PUSH(NIL);
pv = &Stack[SP-1];
while (eval(*cond, penv) != NIL) {
*penv = Stack[saveSP+1];
*body = Stack[SP-2];
while (iscons(*body)) {
*pv = eval(car_(*body), penv);
*penv = Stack[saveSP+1];
*body = cdr_(*body);
}
}
v = *pv;
break;
case F_PROGN:
// return last arg
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
// ordinary functions
case F_SET:
argcount("set", nargs, 2);
e = Stack[SP-2];
v = *penv;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == e) {
cdr_(bind) = (v=Stack[SP-1]);
SP=saveSP;
return v;
}
v = cdr_(v);
}
tosymbol(e, "set")->binding = (v=Stack[SP-1]);
break;
case F_BOUNDP:
argcount("boundp", nargs, 1);
sym = tosymbol(Stack[SP-1], "boundp");
if (sym->binding == UNBOUND && sym->constant == UNBOUND)
v = NIL;
else
v = T;
break;
case F_EQ:
argcount("eq", nargs, 2);
v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
break;
case F_CONS:
argcount("cons", nargs, 2);
v = mk_cons();
car_(v) = Stack[SP-2];
cdr_(v) = Stack[SP-1];
break;
case F_CAR:
argcount("car", nargs, 1);
v = car(Stack[SP-1]);
break;
case F_CDR:
argcount("cdr", nargs, 1);
v = cdr(Stack[SP-1]);
break;
case F_RPLACA:
argcount("rplaca", nargs, 2);
car(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_RPLACD:
argcount("rplacd", nargs, 2);
cdr(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_ATOM:
argcount("atom", nargs, 1);
v = ((!iscons(Stack[SP-1])) ? T : NIL);
break;
case F_SYMBOLP:
argcount("symbolp", nargs, 1);
v = ((issymbol(Stack[SP-1])) ? T : NIL);
break;
case F_NUMBERP:
argcount("numberp", nargs, 1);
v = ((isnumber(Stack[SP-1])) ? T : NIL);
break;
case F_ADD:
s = 0;
for (i=saveSP+2; i < (int)SP; i++) {
n = tonumber(Stack[i], "+");
s += n;
}
v = number(s);
break;
case F_SUB:
if (nargs < 1)
lerror("-: error: too few arguments\n");
i = saveSP+2;
s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "-");
s -= n;
}
v = number(s);
break;
case F_MUL:
s = 1;
for (i=saveSP+2; i < (int)SP; i++) {
n = tonumber(Stack[i], "*");
s *= n;
}
v = number(s);
break;
case F_DIV:
if (nargs < 1)
lerror("/: error: too few arguments\n");
i = saveSP+2;
s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "/");
if (n == 0)
lerror("/: error: division by zero\n");
s /= n;
}
v = number(s);
break;
case F_LT:
argcount("<", nargs, 2);
if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
v = T;
else
v = NIL;
break;
case F_NOT:
argcount("not", nargs, 1);
v = ((Stack[SP-1] == NIL) ? T : NIL);
break;
case F_EVAL:
argcount("eval", nargs, 1);
v = Stack[SP-1];
tail_eval(v, NIL);
break;
case F_PRINT:
for (i=saveSP+2; i < (int)SP; i++)
print(stdout, v=Stack[i]);
break;
case F_READ:
argcount("read", nargs, 0);
v = read_sexpr(stdin);
break;
case F_LOAD:
argcount("load", nargs, 1);
v = load_file(tosymbol(Stack[SP-1], "load")->name);
break;
case F_PROG1:
// return first arg
if (nargs < 1)
lerror("prog1: error: too few arguments\n");
v = Stack[saveSP+2];
break;
case F_APPLY:
argcount("apply", nargs, 2);
v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
f = Stack[SP-2]; // first arg is new function
POPN(2); // pop apply's args
if (isbuiltin(f)) {
if (isspecial(f))
lerror("apply: error: cannot apply special operator "
"%s\n", builtin_names[intval(f)]);
// unpack arglist onto the stack
while (iscons(v)) {
PUSH(car_(v));
v = cdr_(v);
}
goto apply_builtin;
}
noeval = 1;
goto apply_lambda;
}
SP = saveSP;
return v;
}
else {
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
apply_lambda:
if (iscons(f)) {
headsym = car_(f);
if (headsym == LABEL) {
// (label name (lambda ...)) behaves the same as the lambda
// alone, except with name bound to the whole label expression
labl = f;
f = car(cdr(cdr_(labl)));
headsym = car(f);
}
// apply lambda or macro expression
PUSH(cdr(cdr(cdr_(f))));
lenv = &Stack[SP-1];
PUSH(car_(cdr_(f)));
argsyms = &Stack[SP-1];
PUSH(car_(cdr_(cdr_(f))));
body = &Stack[SP-1];
if (labl) {
// add label binding to environment
PUSH(labl);
PUSH(car_(cdr_(labl)));
*lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
POPN(3);
v = Stack[saveSP]; // refetch arglist
}
if (headsym == MACRO)
noeval = 1;
else if (headsym != LAMBDA)
lerror("apply: error: head must be lambda, macro, or label\n");
// build a calling environment for the lambda
// the environment is the argument binds on top of the captured
// environment
while (iscons(v)) {
// bind args
if (!iscons(*argsyms)) {
if (*argsyms == NIL)
lerror("apply: error: too many arguments\n");
break;
}
asym = car_(*argsyms);
if (!issymbol(asym))
lerror("apply: error: formal argument not a symbol\n");
v = car_(v);
if (!noeval) {
v = eval(v, penv);
*penv = Stack[saveSP+1];
}
PUSH(v);
*lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
POPN(2);
*argsyms = cdr_(*argsyms);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
if (*argsyms != NIL) {
if (issymbol(*argsyms)) {
if (noeval) {
*lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
}
else {
PUSH(NIL);
PUSH(NIL);
rest = &Stack[SP-1];
// build list of rest arguments
// we have to build it forwards, which is tricky
while (iscons(v)) {
v = eval(car_(v), penv);
*penv = Stack[saveSP+1];
PUSH(v);
v = cons_(&Stack[SP-1], &NIL);
POP();
if (iscons(*rest))
cdr_(*rest) = v;
else
Stack[SP-2] = v;
*rest = v;
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
*lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
}
}
else if (iscons(*argsyms)) {
lerror("apply: error: too few arguments\n");
}
}
noeval = 0;
// macro: evaluate expansion in the calling environment
if (headsym == MACRO) {
SP = saveSP;
PUSH(*lenv);
lenv = &Stack[SP-1];
v = eval(*body, lenv);
tail_eval(v, *penv);
}
else {
tail_eval(*body, *lenv);
}
// not reached
}
type_error("apply", "function", f);
return NIL;
}
void* SimulationResultsCmp_compareResults(const char *filename, const char *reffilename, const char *resultfilename, double reltol, double abstol, void *vars)
{
char **cmpvars=NULL;
char **cmpdiffvars=NULL;
unsigned int vardiffindx=0;
unsigned int ncmpvars = 0;
void *allvars,*cmpvar,*res;
unsigned int i,size,size_ref,len,oldlen,j,k;
char *var,*var1,*var2;
DataField time,timeref,data,dataref;
DiffDataField ddf;
const char *msg[2] = {"",""};
ddf.data=NULL;
ddf.n=0;
oldlen = 0;
len = 1;
/* open files */
/* fprintf(stderr, "Open File %s\n", filename); */
if (UNKNOWN_PLOT == SimulationResultsImpl__openFile(filename,&simresglob_c)) return mk_cons(mk_scon("Error Open File!"),mk_nil());
/* fprintf(stderr, "Open File %s\n", reffilename); */
if (UNKNOWN_PLOT == SimulationResultsImpl__openFile(reffilename,&simresglob_ref)) return mk_cons(mk_scon("Error Open RefFile!"),mk_nil());
size = SimulationResultsImpl__readSimulationResultSize(filename,&simresglob_c);
/* fprintf(stderr, "Read size of File %s size= %d\n", filename,size); */
size_ref = SimulationResultsImpl__readSimulationResultSize(reffilename,&simresglob_ref);
/* fprintf(stderr, "Read size of File %s size= %d\n", reffilename,size_ref); */
/* get vars to compare */
cmpvars = getVars(vars,&ncmpvars);
/* if no var compare all vars */
if (ncmpvars==0){
allvars = SimulationResultsImpl__readVars(filename,&simresglob_c);
cmpvars = getVars(vars,&ncmpvars);
if (ncmpvars==0) return mk_cons(mk_scon("Error Get Vars!"),mk_nil());
}
cmpdiffvars = (char**)malloc(sizeof(char*)*(ncmpvars));
/* fprintf(stderr, "Compare Vars:\n"); /*
/* for(i=0;i<ncmpvars;i++)
fprintf(stderr, "Var: %s\n", cmpvars[i]); */
/* get time */
/* fprintf(stderr, "get time\n"); */
time = getData("time",filename,size,&simresglob_c);
if (time.n==0)
{
time = getData("Time",filename,size,&simresglob_c);
if (time.n==0){
/* fprintf(stderr, "Cannot get var time\n"); */
return mk_cons(mk_scon("Error get time!"),mk_nil());
}
}
/* fprintf(stderr, "get reftime\n"); */
timeref = getData("time",reffilename,size_ref,&simresglob_ref);
if (timeref.n==0)
{
timeref = getData("Time",reffilename,size_ref,&simresglob_ref);
if (timeref.n==0){
/* fprintf(stderr, "Cannot get var reftime\n"); */
return mk_cons(mk_scon("Error get ref time!"),mk_nil());
}
}
var1=NULL;
var2=NULL;
/* compare vars */
/* fprintf(stderr, "compare vars\n"); */
for (i=0;i<ncmpvars;i++) {
var = cmpvars[i];
len = strlen(var);
if (oldlen < len) {
if (var1) free(var1);
var1 = (char*) malloc(len+1);
oldlen = len;
}
memset(var1,0,len);
k = 0;
for (j=0;j<len;j++) {
if (var[j] !='\"' ) {
var1[k] = var[j];
k +=1;
}
}
/* fprintf(stderr, "compare var: %s\n",var); */
/* check if in ref_file */
dataref = getData(var1,reffilename,size_ref,&simresglob_ref);
if (dataref.n==0) {
if (var2) free(var2);
var2 = (char*) malloc(len+1);
strncpy(var2,var1,len+1);
fixDerInName(var2,len);
fixCommaInName(&var2,len);
dataref = getData(var2,reffilename,size_ref,&simresglob_ref);
if (dataref.n==0) {
fprintf(stderr, "Get Data of Var %s from file %s failed\n",var,reffilename);
c_add_message(-1, ErrorType_scripting, ErrorLevel_warning, "Get Data of Var failed!\n", msg, 0);
continue;
}
}
/* check if in file */
data = getData(var1,filename,size,&simresglob_c);
if (data.n==0) {
fixDerInName(var1,len);
fixCommaInName(&var1,len);
data = getData(var1,filename,size,&simresglob_c);
if (data.n==0) {
if (data.data) free(data.data);
fprintf(stderr, "Get Data of Var %s from file %s failed\n",var,filename);
c_add_message(-1, ErrorType_scripting, ErrorLevel_warning, "Get Data of Var failed!\n", msg, 0);
continue;
}
}
/* compare */
vardiffindx = cmpData(var,&time,&timeref,&data,&dataref,reltol,abstol,&ddf,cmpdiffvars,vardiffindx);
/* free */
if (dataref.data) free(dataref.data);
if (data.data) free(data.data);
}
if (writeLogFile(resultfilename,&ddf,filename,reffilename,reltol,abstol))
{
c_add_message(-1, ErrorType_scripting, ErrorLevel_warning, "Cannot write result file!\n", msg, 0);
}
if (ddf.n > 0){
/* fprintf(stderr, "diff: %d\n",ddf.n); */
/* for (i=0;i<vardiffindx;i++)
fprintf(stderr, "diffVar: %s\n",cmpdiffvars[i]); */
res = mk_nil();
for (i=0;i<vardiffindx;i++){
res = (void*)mk_cons(mk_scon(cmpdiffvars[i]),res);
}
res = mk_cons(mk_scon("Files not Equal!"),res);
c_add_message(-1, ErrorType_scripting, ErrorLevel_warning, "Files not Equal\n", msg, 0);
}
else
res = mk_cons(mk_scon("Files Equal!"),mk_nil());
if (var1) free(var1);
if (var2) free(var2);
if (ddf.data) free(ddf.data);
if(cmpvars) free(cmpvars);
if (time.data) free(time.data);
if (timeref.data) free(timeref.data);
if (cmpdiffvars) free(cmpdiffvars);
/* close files */
SimulationResultsImpl__close(&simresglob_c);
SimulationResultsImpl__close(&simresglob_ref);
return res;
}
