static void
yyerf(void)
{
double d;
p1 = pop();
if (isdouble(p1)) {
d = 1.0 - erfc(p1->u.d);
push_double(d);
return;
}
if (isnegativeterm(p1)) {
push_symbol(ERF);
push(p1);
negate();
list(2);
negate();
return;
}
push_symbol(ERF);
push(p1);
list(2);
return;
}
void
arcsinh(void)
{
double d;
save();
p1 = pop();
if (car(p1) == symbol(SINH)) {
push(cadr(p1));
restore();
return;
}
if (isdouble(p1)) {
d = p1->u.d;
d = log(d + sqrt(d * d + 1.0));
push_double(d);
restore();
return;
}
if (iszero(p1)) {
push(zero);
restore();
return;
}
push_symbol(ARCSINH);
push(p1);
list(2);
restore();
}
void gather_symbols(SE *code) {
char *opsym;
while(code!=NULL) {
/* unarne CONST, LOOKUP i FORGET przeskakujemy od razu */
opsym=symval(car(code));
if(strcmp(opsym,"const")==0 || strcmp(opsym,"lookup")==0 || strcmp(opsym,"forget")==0) {
code=cdr(cdr(code)); continue;
} else /* NAME to to czego szukamy */ if(strcmp(opsym,"name")==0) {
push_symbol(symval(car(cdr(code))));
code=cdr(cdr(code));
continue;
} else /* może S(R)ELECT? */ if(strcmp(opsym,"select")==0 || strcmp(opsym,"srelect")==0) {
/* teraz czytelnik może się faktycznie wzruszyć */
gather_symbols(car(cdr(code)));
gather_symbols(car(cdr(cdr(code))));
code=cdr(cdr(cdr(code)));
continue;
} else /* może chociaż PROC? */ if(strcmp(opsym,"proc")==0) {
gather_symbols(car(cdr(code)));
code=cdr(cdr(code));
continue;
} else /* a więc nic ciekawego */ {
code=cdr(code);
}
} /* while... */
}
void
exponential(void)
{
push_symbol(E);
swap();
power();
}
void
arctanh(void)
{
double d;
save();
p1 = pop();
if (car(p1) == symbol(TANH)) {
push(cadr(p1));
restore();
return;
}
if (isdouble(p1)) {
d = p1->u.d;
if (d < -1.0 || d > 1.0)
stop("arctanh function argument is not in the interval [-1,1]");
d = log((1.0 + d) / (1.0 - d)) / 2.0;
push_double(d);
restore();
return;
}
if (iszero(p1)) {
push(zero);
restore();
return;
}
push_symbol(ARCTANH);
push(p1);
list(2);
restore();
}
void
yyhermite(void)
{
int n;
N = pop();
X = pop();
push(N);
n = pop_integer();
if (n < 0) {
push_symbol(HERMITE);
push(X);
push(N);
list(3);
return;
}
if (issymbol(X))
yyhermite2(n);
else {
Y = X; // do this when X is an expr
X = symbol(SECRETX);
yyhermite2(n);
X = Y;
push(symbol(SECRETX));
push(X);
subst();
eval();
}
}
void _def(){
struct symbol *sym;
struct atom *id;
struct atom *ref;
char *ident;
id = u_pop_atom();
if(id->type != IDENT)
error("Call: def: Arg 1: IDENT exected.");
ref = u_pop_atom();
if(ref->type != REF)
error("Call: def: Arg 2: REF expected.");
ident = id->data.string_t;
sym = search_symbol_table(ident);
if(sym)
sym->sl = ref->data.jump_t;
else
push_symbol(ident,ref->data.jump_t);
free(id);
free(ref);
}
void
arccosh(void)
{
double d;
save();
p1 = pop();
if (car(p1) == symbol(COSH)) {
push(cadr(p1));
restore();
return;
}
if (isdouble(p1)) {
d = p1->u.d;
if (d < 1.0)
stop("arccosh function argument is less than 1.0");
d = log(d + sqrt(d * d - 1.0));
push_double(d);
restore();
return;
}
if (isplusone(p1)) {
push(zero);
restore();
return;
}
push_symbol(ARCCOSH);
push(p1);
list(2);
restore();
}
void
dfunction(void)
{
p3 = cdr(p1); // p3 is the argument list for the function
if (p3 == symbol(NIL) || find(p3, p2)) {
push_symbol(DERIVATIVE);
push(p1);
push(p2);
list(3);
} else
push(zero);
}
_symbol *update_table (char *symbol)
{
unsigned int index;
_symbol *entry;
index = hash(symbol);
entry = look_up_symbol(symbol, index);
if (entry == NULL) {
entry = write_symbol(symbol, SYMBOL, index);
push_symbol(entry);
}
return entry;
}
//略过第一个符号 'var'
void grammar_parser::declare(set<e_word_t> follows,int& stk_index)
{
word ident=m_words.get();
if(ident.m_type==ewt_ident)
{
grammar_debug(ident);
_symbol* p_sym=NULL;
if((get_top_gener_id()==1)&& (get_global_table()==get_top_table()))
{
p_sym=push_symbol(_symbol(es_value,ident.m_str_value,eab_global_data,alloc_global_data_space()),true);
}
else
{
p_sym=push_symbol(_symbol(es_value,ident.m_str_value,eab_reg_sb,stk_index));
gen_load_const_instruction(stk_index,0);
}
word assgin=m_words.get();
if(assgin.m_type==ewt_key_assign)
{
grammar_debug(assgin);
expression(follows,stk_index);
if(p_sym) gen_code(e_save,p_sym->m_addr_t,p_sym->m_addr);
gen_pop_instruction(stk_index);
}
else m_words.push(assgin);
word semicolon=m_words.get();
if(semicolon.m_type==ewt_key_semicolon)
{
grammar_debug(semicolon);
return;
}
else m_words.push(semicolon);
}
else m_words.push(ident);
test_and_skip(follows,_create_syms());
}
void
dd(void)
{
// d(f(x,y),x)
push(cadr(p1));
push(p2);
derivative();
p3 = pop();
if (car(p3) == symbol(DERIVATIVE)) {
// sort dx terms
push_symbol(DERIVATIVE);
push_symbol(DERIVATIVE);
push(cadr(p3));
if (lessp(caddr(p3), caddr(p1))) {
push(caddr(p3));
list(3);
push(caddr(p1));
} else {
push(caddr(p1));
list(3);
push(caddr(p3));
}
list(3);
} else {
push(p3);
push(caddr(p1));
derivative();
}
}
void
yybessely(void)
{
double d;
int n;
N = pop();
X = pop();
push(N);
n = pop_integer();
if (isdouble(X) && n != (int) 0x80000000) {
d = yn(n, X->u.d);
push_double(d);
return;
}
if (isnegativeterm(N)) {
push_integer(-1);
push(N);
power();
push_symbol(BESSELY);
push(X);
push(N);
negate();
list(3);
multiply();
return;
}
push_symbol(BESSELY);
push(X);
push(N);
list(3);
return;
}
void push_core_functions(){
int i;
for(i=0; core_functions[i] != NULL; i++){
//vsp should be the start location of the function
push_symbol(fn_names[i],vsp);
//push the function
push_start();
push_call(core_functions[i]);
push_term();
//vsp should now be the stack location just after the function.
//This space should later be filled by the start of the users
//program.
exec_entry_pt = vsp;
}
}
void
sgn(void)
{
save();
p1 = pop();
if (!isnum(p1)) {
push_symbol(SGN);
push(p1);
list(2);
} else if (iszero(p1))
push_integer(0);
else if (isnegativenumber(p1))
push_integer(-1);
else
push_integer(1);
restore();
}
//略过第一个符号 'function'
void grammar_parser::function(set<e_word_t> follows)
{
//堆栈的样子
//param1,param2,param3,param_count,ret_vaule,prev_reg_sb,prev_reg_ip,其中prev_reg_sb对应堆栈起始位置
word ident=m_words.get();
if(ident.m_type==ewt_ident)
{
grammar_debug(ident);
_symbol* p_sym=push_symbol(_symbol(es_function,ident.m_str_value,eab_absolute_ip,get_new_code_addr(true)),true);
if(get_top_gener_id()>1) report_error("语法错误：不支持函数内定义函数\n");
_instruction* p_jmp=gen_code(e_jmp,eab_absolute_ip,0,0,true);
create_gener();
create_table();
word lmbrach=m_words.get();
if(lmbrach.m_type=ewt_key_lsbranch)
{
grammar_debug(lmbrach);
p_sym->m_fun_params_count=fun_params(follows);
}
int stk_index=2;
word lbbranch=m_words.get();
if(lbbranch.m_type==ewt_key_lbbranch)
{
grammar_debug(lbbranch);
body(follows,stk_index,NULL);
}
else m_words.push(lbbranch);
gen_code(e_ret);//如果没有写返回语句，加一句默认的返回语句
p_jmp->m_addr=merge_code();
pop_table();
pop_gener();
}
else
{
report_error("语法错误：函数定义缺少函数名\n");
m_words.push(ident);
}
test_and_skip(follows,_create_syms());
}
void
derfc(void)
{
push(cadr(p1));
push_integer(2);
power();
push_integer(-1);
multiply();
exponential();
push_symbol(PI);
push_rational(-1,2);
power();
multiply();
push_integer(-2);
multiply();
push(cadr(p1));
push(p2);
derivative();
multiply();
}
//略过第一个符号 '('
int grammar_parser::fun_params(set<e_word_t> follows)
{
int params_count=0;
vector<_symbol*> syms;
while(true)
{
word tmp=m_words.get();
if(tmp.m_type==ewt_ident)
{
grammar_debug(tmp);
_symbol* p_sym=push_symbol(_symbol(es_value,tmp.m_str_value,eab_reg_sb,params_count));
if(p_sym) syms.push_back(p_sym);
params_count++;
}
else if(tmp.m_type==ewt_key_rsbranch)
{
grammar_debug(tmp);
for(vector<_symbol*>::iterator it=syms.begin();it!=syms.end();it++)
{
(*it)->m_addr-=(params_count+2);
}
return params_count;
}
else
{
m_words.push(tmp);
break;
}
word comma=m_words.get();
if(comma.m_type==ewt_key_comma)
{
grammar_debug(comma);
continue;
}
else m_words.push(comma);
}
test_and_skip(follows,_create_syms());
return 0;
}
void
yysinh(void)
{
double d;
p1 = pop();
if (car(p1) == symbol(ARCSINH)) {
push(cadr(p1));
return;
}
if (isdouble(p1)) {
d = sinh(p1->u.d);
if (fabs(d) < 1e-10)
d = 0.0;
push_double(d);
return;
}
if (iszero(p1)) {
push(zero);
return;
}
push_symbol(SINH);
push(p1);
list(2);
}
void
yyfloor(void)
{
double d;
p1 = pop();
if (!isnum(p1)) {
push_symbol(FLOOR);
push(p1);
list(2);
return;
}
if (isdouble(p1)) {
d = floor(p1->u.d);
push_double(d);
return;
}
if (isinteger(p1)) {
push(p1);
return;
}
p3 = alloc();
p3->k = NUM;
p3->u.q.a = mdiv(p1->u.q.a, p1->u.q.b);
p3->u.q.b = mint(1);
push(p3);
if (isnegativenumber(p1)) {
push_integer(-1);
add();
}
}
/*
parse a simple expression (<num><operation><num>) from the symbol stack
and push the result. expands <num> to identifiers (constants, variables or
functions), and to another expression inside braces.
return 1 if S_EOF is found, 0 otherwise.
*/
bool
ModCalc::parse_expsimple (void)
{
double d = 0;
bool lvalue = 0;
symbol_type *symbol, *op = NULL, *var = NULL;
while (1)
{
symbol = pop_symbol ();
if (symbol == NULL)
{
snprintf (error, MSG_SIZE, "STACK ERROR!");
error_pos = 0;
return 0;
}
error_pos = symbol->pos;
if (symbol->type == S_EOF)
{
if (!lvalue || op != NULL || braces != 0)
{
snprintf (error, MSG_SIZE, "unexpected end of expression");
break;
}
push_symbol (new symbol_type (symbol->pos, d));
delete symbol;
return 1;
}
else if (symbol->type == S_OP)
{
if (symbol->op == OP_ASSIGN)
{
if (var == NULL)
{
snprintf (error, MSG_SIZE, "non-variable lvalue in assignment");
break;
}
}
else
{
if (op != NULL ||
(!lvalue && symbol->op != OP_PLUS && symbol->op != OP_MINUS))
{
if (op != NULL)
snprintf (error, MSG_SIZE, "missing rvalue for operator");
else
snprintf (error, MSG_SIZE, "missing lvalue for operator");
break;
}
if (!lvalue && (symbol->op == OP_PLUS || symbol->op == OP_MINUS))
{
d = 0;
lvalue = 1;
}
}
op = symbol;
}
else if (symbol->type == S_NUM)
{
if (op == NULL)
{
if (lvalue)
{
snprintf (error, MSG_SIZE, "two consecutive values");
break;
}
d = symbol->value;
lvalue = 1;
delete symbol;
continue;
}
if (top != NULL && top->type == S_OP && top->priority > op->priority)
{
push_symbol (new symbol_type (symbol->pos, symbol->value));
parse_expsimple ();
if (error[0] != 0)
break;
delete symbol;
continue;
}
switch (op->op)
{
case OP_ASSIGN:
d = symbol->value;
var_type *v;
vars.rewind ();
while ((v = (var_type *)vars.next ()) != NULL)
if (var->id == v->name)
break;
if (v != NULL)
{
v->value = d;
v->time = get_time ();
}
else
{
vars.add ((void *)new var_type (var->id, d));
if (vars.count () == VARS_MAX)
{
time_t t_old = -1;
var_type *v_old = NULL;
vars.rewind ();
while ((v = (var_type *)vars.next ()) != NULL)
if (v->time < t_old)
{
t_old = v->time;
v_old = v;
}
vars.del ((void *)v_old);
}
}
delete var;
var = NULL;
break;
case OP_PLUS:
d += symbol->value;
break;
case OP_MINUS:
d -= symbol->value;
break;
case OP_TIMES:
d *= symbol->value;
break;
case OP_DIV:
d /= symbol->value;
break;
case OP_MOD:
d = fmod (d, symbol->value);
break;
case OP_POW:
d = pow (d, symbol->value);
break;
case OP_SHIFT_L:
d = ((unsigned long int)d) << ((unsigned long int)symbol->value);
break;
case OP_SHIFT_R:
d = ((unsigned long int)d) >> ((unsigned long int)symbol->value);
break;
case OP_AND:
d = ((unsigned long int)d) & ((unsigned long int)symbol->value);
break;
case OP_OR:
d = ((unsigned long int)d) | ((unsigned long int)symbol->value);
break;
}
push_symbol (new symbol_type (symbol->pos, d));
delete op;
delete symbol;
return 0;
}
else if (symbol->type == S_BRACE_L)
{
int old_braces = braces;
braces++;
while (braces != old_braces)
{
parse_expsimple ();
if (error[0] != 0)
break;
}
delete symbol;
}
else if (symbol->type == S_BRACE_R)
{
if (!lvalue)
snprintf (error, MSG_SIZE, "missing value in braces");
else if (op != NULL)
snprintf (error, MSG_SIZE, "missing rvalue for operator");
else if (braces == 0)
snprintf (error, MSG_SIZE, "extra ')' used");
else
{
braces--;
push_symbol (new symbol_type (symbol->pos, d));
delete symbol;
if (op != NULL)
delete op;
return 0;
}
break;
}
else if (symbol->type == S_ID)
{
if (parse_exp_id (symbol))
{
if (lvalue)
{
snprintf (error, MSG_SIZE, "invalid lvalue in assignment");
break;
}
var = symbol;
}
if (error[0] != 0)
break;
}
}
void
cosine_of_angle(void)
{
int n;
double d;
if (car(p1) == symbol(ARCCOS)) {
push(cadr(p1));
return;
}
if (isdouble(p1)) {
d = cos(p1->u.d);
if (fabs(d) < 1e-10)
d = 0.0;
push_double(d);
return;
}
// cosine function is symmetric, cos(-x) = cos(x)
if (isnegative(p1)) {
push(p1);
negate();
p1 = pop();
}
// cos(arctan(x)) = 1 / sqrt(1 + x^2)
// see p. 173 of the CRC Handbook of Mathematical Sciences
if (car(p1) == symbol(ARCTAN)) {
push_integer(1);
push(cadr(p1));
push_integer(2);
power();
add();
push_rational(-1, 2);
power();
return;
}
// multiply by 180/pi
push(p1);
push_integer(180);
multiply();
push_symbol(PI);
divide();
n = pop_integer();
if (n < 0) {
push(symbol(COS));
push(p1);
list(2);
return;
}
switch (n % 360) {
case 90:
case 270:
push_integer(0);
break;
case 60:
case 300:
push_rational(1, 2);
break;
case 120:
case 240:
push_rational(-1, 2);
break;
case 45:
case 315:
push_rational(1, 2);
push_integer(2);
push_rational(1, 2);
power();
multiply();
break;
case 135:
case 225:
push_rational(-1, 2);
push_integer(2);
push_rational(1, 2);
power();
multiply();
break;
case 30:
case 330:
push_rational(1, 2);
push_integer(3);
push_rational(1, 2);
power();
multiply();
break;
case 150:
case 210:
push_rational(-1, 2);
push_integer(3);
push_rational(1, 2);
power();
multiply();
break;
case 0:
push_integer(1);
break;
case 180:
push_integer(-1);
break;
default:
push(symbol(COS));
push(p1);
list(2);
break;
}
}
void
init(void)
{
int i;
static int flag;
tos = 0;
esc_flag = 0;
draw_flag = 0;
frame = stack + TOS;
p0 = symbol(NIL);
p1 = symbol(NIL);
p2 = symbol(NIL);
p3 = symbol(NIL);
p4 = symbol(NIL);
p5 = symbol(NIL);
p6 = symbol(NIL);
p7 = symbol(NIL);
p8 = symbol(NIL);
p9 = symbol(NIL);
if (flag)
return; // already initted
flag = 1;
for (i = 0; i < NSYM; i++) {
symtab[i].k = SYM;
binding[i] = symtab + i;
arglist[i] = symbol(NIL);
}
std_symbol("abs", ABS);
std_symbol("add", ADD);
std_symbol("adj", ADJ);
std_symbol("and", AND);
std_symbol("arccos", ARCCOS);
std_symbol("arccosh", ARCCOSH);
std_symbol("arcsin", ARCSIN);
std_symbol("arcsinh", ARCSINH);
std_symbol("arctan", ARCTAN);
std_symbol("arctanh", ARCTANH);
std_symbol("arg", ARG);
std_symbol("binding", BINDING);
std_symbol("binomial", BINOMIAL);
std_symbol("ceiling", CEILING);
std_symbol("check", CHECK);
std_symbol("choose", CHOOSE);
std_symbol("circexp", CIRCEXP);
std_symbol("clear", CLEAR);
std_symbol("clock", CLOCK);
std_symbol("coeff", COEFF);
std_symbol("cofactor", COFACTOR);
std_symbol("condense", CONDENSE);
std_symbol("conj", CONJ);
std_symbol("contract", CONTRACT);
std_symbol("cos", COS);
std_symbol("cosh", COSH);
std_symbol("decomp", DECOMP);
std_symbol("defint", DEFINT);
std_symbol("deg", DEGREE);
std_symbol("denominator", DENOMINATOR);
std_symbol("det", DET);
std_symbol("derivative", DERIVATIVE);
std_symbol("dim", DIM);
std_symbol("dirac", DIRAC);
std_symbol("divisors", DIVISORS);
std_symbol("do", DO);
std_symbol("dot", DOT);
std_symbol("draw", DRAW);
std_symbol("dsolve", DSOLVE);
std_symbol("erf", ERF);
std_symbol("erfc", ERFC);
std_symbol("eigen", EIGEN);
std_symbol("eigenval", EIGENVAL);
std_symbol("eigenvec", EIGENVEC);
std_symbol("eval", EVAL);
std_symbol("exp", EXP);
std_symbol("expand", EXPAND);
std_symbol("expcos", EXPCOS);
std_symbol("expsin", EXPSIN);
std_symbol("factor", FACTOR);
std_symbol("factorial", FACTORIAL);
std_symbol("factorpoly", FACTORPOLY);
std_symbol("filter", FILTER);
std_symbol("float", FLOATF);
std_symbol("floor", FLOOR);
std_symbol("for", FOR);
std_symbol("Gamma", GAMMA);
std_symbol("gcd", GCD);
std_symbol("hermite", HERMITE);
std_symbol("hilbert", HILBERT);
std_symbol("imag", IMAG);
std_symbol("component", INDEX);
std_symbol("inner", INNER);
std_symbol("integral", INTEGRAL);
std_symbol("inv", INV);
std_symbol("invg", INVG);
std_symbol("isinteger", ISINTEGER);
std_symbol("isprime", ISPRIME);
std_symbol("laguerre", LAGUERRE);
std_symbol("lcm", LCM);
std_symbol("leading", LEADING);
std_symbol("legendre", LEGENDRE);
std_symbol("log", LOG);
std_symbol("mag", MAG);
std_symbol("mod", MOD);
std_symbol("multiply", MULTIPLY);
std_symbol("not", NOT);
std_symbol("nroots", NROOTS);
std_symbol("number", NUMBER);
std_symbol("numerator", NUMERATOR);
std_symbol("operator", OPERATOR);
std_symbol("or", OR);
std_symbol("outer", OUTER);
std_symbol("polar", POLAR);
std_symbol("power", POWER);
std_symbol("prime", PRIME);
std_symbol("print", PRINT);
std_symbol("product", PRODUCT);
std_symbol("quote", QUOTE);
std_symbol("quotient", QUOTIENT);
std_symbol("rank", RANK);
std_symbol("rationalize", RATIONALIZE);
std_symbol("real", REAL);
std_symbol("rect", YYRECT);
std_symbol("roots", ROOTS);
std_symbol("equals", SETQ);
std_symbol("sgn", SGN);
std_symbol("simplify", SIMPLIFY);
std_symbol("sin", SIN);
std_symbol("sinh", SINH);
std_symbol("sqrt", SQRT);
std_symbol("stop", STOP);
std_symbol("subst", SUBST);
std_symbol("sum", SUM);
std_symbol("tan", TAN);
std_symbol("tanh", TANH);
std_symbol("taylor", TAYLOR);
std_symbol("test", TEST);
std_symbol("testeq", TESTEQ);
std_symbol("testge", TESTGE);
std_symbol("testgt", TESTGT);
std_symbol("testle", TESTLE);
std_symbol("testlt", TESTLT);
std_symbol("transpose", TRANSPOSE);
std_symbol("unit", UNIT);
std_symbol("zero", ZERO);
std_symbol("nil", NIL);
// each symbol needs a unique name because equal() compares printnames
std_symbol("autoexpand", AUTOEXPAND);
std_symbol("bake", BAKE);
std_symbol("last", LAST);
std_symbol("trace", TRACE);
std_symbol("~", YYE); // tilde so sort puts it after other symbols
std_symbol("$DRAWX", DRAWX); // special purpose internal symbols
std_symbol("$METAA", METAA);
std_symbol("$METAB", METAB);
std_symbol("$METAX", METAX);
std_symbol("$SECRETX", SECRETX);
std_symbol("pi", PI);
std_symbol("a", SYMBOL_A);
std_symbol("b", SYMBOL_B);
std_symbol("c", SYMBOL_C);
std_symbol("d", SYMBOL_D);
std_symbol("i", SYMBOL_I);
std_symbol("j", SYMBOL_J);
std_symbol("n", SYMBOL_N);
std_symbol("r", SYMBOL_R);
std_symbol("s", SYMBOL_S);
std_symbol("t", SYMBOL_T);
std_symbol("x", SYMBOL_X);
std_symbol("y", SYMBOL_Y);
std_symbol("z", SYMBOL_Z);
#ifdef ARM9
std_symbol("\234", SYMBOL_I);
std_symbol("\227", USR_INTEGRAL);
std_symbol("\230", USR_DERIVATIVE);
//std_symbol("\231", SQRT);
//std_symbol("\232", SUM);
std_symbol("\233", PI);
//std_symbol("\234", IMAG);
//std_symbol("\235", EXP);
#endif
std_symbol("$C1", C1);
std_symbol("$C2", C2);
std_symbol("$C3", C3);
std_symbol("$C4", C4);
std_symbol("$C5", C5);
std_symbol("$C6", C6);
push_integer(0);
zero = pop(); // must be untagged in gc
push_integer(1);
one = pop(); // must be untagged in gc
push_symbol(POWER);
push_integer(-1);
push_rational(1, 2);
list(3);
imaginaryunit = pop(); // must be untagged in gc
defn();
}
void
absval(void)
{
int h;
save();
p1 = pop();
if (istensor(p1)) {
absval_tensor();
restore();
return;
}
if (isnum(p1)) {
push(p1);
if (isnegativenumber(p1))
negate();
restore();
return;
}
if (iscomplexnumber(p1)) {
push(p1);
push(p1);
conjugate();
multiply();
push_rational(1, 2);
power();
restore();
return;
}
// abs(1/a) evaluates to 1/abs(a)
if (car(p1) == symbol(POWER) && isnegativeterm(caddr(p1))) {
push(p1);
reciprocate();
absval();
reciprocate();
restore();
return;
}
// abs(a*b) evaluates to abs(a)*abs(b)
if (car(p1) == symbol(MULTIPLY)) {
h = tos;
p1 = cdr(p1);
while (iscons(p1)) {
push(car(p1));
absval();
p1 = cdr(p1);
}
multiply_all(tos - h);
restore();
return;
}
if (isnegativeterm(p1) || (car(p1) == symbol(ADD) && isnegativeterm(cadr(p1)))) {
push(p1);
negate();
p1 = pop();
}
push_symbol(ABS);
push(p1);
list(2);
restore();
}
void
yypower(void)
{
int n;
p2 = pop();
p1 = pop();
// both base and exponent are rational numbers?
if (isrational(p1) && isrational(p2)) {
push(p1);
push(p2);
qpow();
return;
}
// both base and exponent are either rational or double?
if (isnum(p1) && isnum(p2)) {
push(p1);
push(p2);
dpow();
return;
}
if (istensor(p1)) {
power_tensor();
return;
}
if (p1 == symbol(E) && car(p2) == symbol(LOG)) {
push(cadr(p2));
return;
}
if (p1 == symbol(E) && isdouble(p2)) {
push_double(exp(p2->u.d));
return;
}
// 1 ^ a -> 1
// a ^ 0 -> 1
if (equal(p1, one) || iszero(p2)) {
push(one);
return;
}
// a ^ 1 -> a
if (equal(p2, one)) {
push(p1);
return;
}
// (a * b) ^ c -> (a ^ c) * (b ^ c)
if (car(p1) == symbol(MULTIPLY)) {
p1 = cdr(p1);
push(car(p1));
push(p2);
power();
p1 = cdr(p1);
while (iscons(p1)) {
push(car(p1));
push(p2);
power();
multiply();
p1 = cdr(p1);
}
return;
}
// (a ^ b) ^ c -> a ^ (b * c)
if (car(p1) == symbol(POWER)) {
push(cadr(p1));
push(caddr(p1));
push(p2);
multiply();
power();
return;
}
// (a + b) ^ n -> (a + b) * (a + b) ...
if (expanding && isadd(p1) && isnum(p2)) {
push(p2);
n = pop_integer();
// this && n != 0x80000000 added by DDC
// as it's not always the case that 0x80000000
// is negative
if (n > 1 && n != 0x80000000) {
power_sum(n);
return;
}
}
// sin(x) ^ 2n -> (1 - cos(x) ^ 2) ^ n
if (trigmode == 1 && car(p1) == symbol(SIN) && iseveninteger(p2)) {
push_integer(1);
push(cadr(p1));
cosine();
push_integer(2);
power();
subtract();
push(p2);
push_rational(1, 2);
multiply();
power();
return;
}
// cos(x) ^ 2n -> (1 - sin(x) ^ 2) ^ n
if (trigmode == 2 && car(p1) == symbol(COS) && iseveninteger(p2)) {
push_integer(1);
push(cadr(p1));
sine();
push_integer(2);
power();
subtract();
push(p2);
push_rational(1, 2);
multiply();
power();
return;
}
// complex number? (just number, not expression)
if (iscomplexnumber(p1)) {
// integer power?
// n will be negative here, positive n already handled
if (isinteger(p2)) {
// / \ n
// -n | a - ib |
// (a + ib) = | -------- |
// | 2 2 |
// \ a + b /
push(p1);
conjugate();
p3 = pop();
push(p3);
push(p3);
push(p1);
multiply();
divide();
push(p2);
negate();
power();
return;
}
// noninteger or floating power?
if (isnum(p2)) {
#if 1 // use polar form
push(p1);
mag();
push(p2);
power();
push_integer(-1);
push(p1);
arg();
push(p2);
multiply();
push(symbol(PI));
divide();
power();
multiply();
#else // use exponential form
push(p1);
mag();
push(p2);
power();
push(symbol(E));
push(p1);
arg();
push(p2);
multiply();
push(imaginaryunit);
multiply();
power();
multiply();
#endif
return;
}
}
if (simplify_polar())
return;
push_symbol(POWER);
push(p1);
push(p2);
list(3);
}
void
yybesselj(void)
{
double d;
int n;
N = pop();
X = pop();
push(N);
n = pop_integer();
// numerical result
if (isdouble(X) && n != (int) 0x80000000) {
//d = jn(n, X->u.d);
push_double(d);
return;
}
// bessej(0,0) = 1
if (iszero(X) && iszero(N)) {
push_integer(1);
return;
}
// besselj(0,n) = 0
if (iszero(X) && n != (int) 0x80000000) {
push_integer(0);
return;
}
// half arguments
if (N->k == NUM && MEQUAL(N->u.q.b, 2)) {
// n = 1/2
if (MEQUAL(N->u.q.a, 1)) {
push_integer(2);
push_symbol(PI);
divide();
push(X);
divide();
push_rational(1, 2);
power();
push(X);
sine();
multiply();
return;
}
// n = -1/2
if (MEQUAL(N->u.q.a, -1)) {
push_integer(2);
push_symbol(PI);
divide();
push(X);
divide();
push_rational(1, 2);
power();
push(X);
cosine();
multiply();
return;
}
// besselj(x,n) = (2/x) (n-sgn(n)) besselj(x,n-sgn(n)) - besselj(x,n-2*sgn(n))
push_integer(MSIGN(N->u.q.a));
SGN = pop();
push_integer(2);
push(X);
divide();
push(N);
push(SGN);
subtract();
multiply();
push(X);
push(N);
push(SGN);
subtract();
besselj();
multiply();
push(X);
push(N);
push_integer(2);
push(SGN);
multiply();
subtract();
besselj();
subtract();
return;
}
push(symbol(BESSELJ));
push(X);
push(N);
list(3);
}
void init_symbols_list() { symbols_p=0; push_symbol("t"); }
void
add_terms(int n)
{
stackAddsCounts++;
int i, h;
U **s;
h = tos - n;
s = stack + h;
printf("stack before adding terms #%d\n", stackAddsCounts);
if (stackAddsCounts == 137)
printf("stop here");
for (i = 0; i < tos; i++) {
print1(stack[i]);
printstr("\n");
}
/* ensure no infinite loop, use "for" */
for (i = 0; i < 10; i++) {
if (n < 2)
break;
flag = 0;
qsort(s, n, sizeof (U *), cmp_terms);
if (flag == 0)
break;
n = combine_terms(s, n);
}
tos = h + n;
switch (n) {
case 0:
push_integer(0);
break;
case 1:
break;
default:
list(n);
p1 = pop();
push_symbol(ADD);
push(p1);
cons();
break;
}
printf("stack after adding terms #%d\n", stackAddsCounts);
if (stackAddsCounts == 5)
printf("stop here");
for (i = 0; i < tos; i++) {
print1(stack[i]);
printstr("\n");
}
}
void
arctan(void)
{
double d;
save();
p1 = pop();
if (car(p1) == symbol(TAN)) {
push(cadr(p1));
restore();
return;
}
if (isdouble(p1)) {
errno = 0;
d = atan(p1->u.d);
if (errno)
stop("arctan function error");
push_double(d);
restore();
return;
}
if (iszero(p1)) {
push(zero);
restore();
return;
}
if (isnegative(p1)) {
push(p1);
negate();
arctan();
negate();
restore();
return;
}
// arctan(sin(a) / cos(a)) ?
if (find(p1, symbol(SIN)) && find(p1, symbol(COS))) {
push(p1);
numerator();
p2 = pop();
push(p1);
denominator();
p3 = pop();
if (car(p2) == symbol(SIN) && car(p3) == symbol(COS) && equal(cadr(p2), cadr(p3))) {
push(cadr(p2));
restore();
return;
}
}
// arctan(1/sqrt(3)) -> pi/6
if (car(p1) == symbol(POWER) && equaln(cadr(p1), 3) && equalq(caddr(p1), -1, 2)) {
push_rational(1, 6);
push(symbol(PI));
multiply();
restore();
return;
}
// arctan(1) -> pi/4
if (equaln(p1, 1)) {
push_rational(1, 4);
push(symbol(PI));
multiply();
restore();
return;
}
// arctan(sqrt(3)) -> pi/3
if (car(p1) == symbol(POWER) && equaln(cadr(p1), 3) && equalq(caddr(p1), 1, 2)) {
push_rational(1, 3);
push(symbol(PI));
multiply();
restore();
return;
}
push_symbol(ARCTAN);
push(p1);
list(2);
restore();
}
void
top_level_eval(void)
{
save();
trigmode = 0;
p1 = symbol(AUTOEXPAND);
if (iszero(get_binding(p1)))
expanding = 0;
else
expanding = 1;
p1 = pop();
push(p1);
eval();
p2 = pop();
// "draw", "for" and "setq" return "nil", there is no result to print
if (p2 == symbol(NIL)) {
push(p2);
restore();
return;
}
// update "last"
set_binding(symbol(LAST), p2);
if (!iszero(get_binding(symbol(BAKE)))) {
push(p2);
bake();
p2 = pop();
}
// If we evaluated the symbol "i" or "j" and the result was sqrt(-1)
// then don't do anything.
// Otherwise if "j" is an imaginary unit then subst.
// Otherwise if "i" is an imaginary unit then subst.
if ((p1 == symbol(SYMBOL_I) || p1 == symbol(SYMBOL_J))
&& isimaginaryunit(p2))
;
else if (isimaginaryunit(get_binding(symbol(SYMBOL_J)))) {
push(p2);
push(imaginaryunit);
push_symbol(SYMBOL_J);
subst();
p2 = pop();
} else if (isimaginaryunit(get_binding(symbol(SYMBOL_I)))) {
push(p2);
push(imaginaryunit);
push_symbol(SYMBOL_I);
subst();
p2 = pop();
}
#ifndef LINUX
// if we evaluated the symbol "a" and got "b" then print "a=b"
// do not print "a=a"
if (issymbol(p1) && !iskeyword(p1) && p1 != p2 && test_flag == 0) {
push_symbol(SETQ);
push(p1);
push(p2);
list(3);
p2 = pop();
}
#endif
push(p2);
restore();
}
