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