int f_regsetq(int arglist){
int arg1,arg2;
checkarg(LEN2_TEST, "regsetq", arglist);
checkarg(SYMBOL_TEST, "regsetq", car(arglist));
arg1 = car(arglist);
arg2 = cadr(arglist);
if(HAS_NAME(arg1,"H"))
H = GET_NUMBER(arg2);
else
if(HAS_NAME(arg1,"E"))
E = GET_NUMBER(arg2);
else
if(HAS_NAME(arg1,"F"))
F = GET_NUMBER(arg2);
else
if(HAS_NAME(arg1,"S"))
S = GET_NUMBER(arg2);
else
if(HAS_NAME(arg1,"C"))
C = GET_NUMBER(arg2);
else
if(HAS_NAME(arg1,"A"))
A = GET_NUMBER(arg2);
else
if(HAS_NAME(arg1,"P"))
P = GET_NUMBER(arg2);
return(makeT());
}
int f_argstkdump(int arglist){
int arg1;
checkarg(LEN1_TEST, "hdmp", arglist);
arg1 = GET_NUMBER(car(arglist));
argstkdump(arg1,arg1+10);
return(makeT());
}
int f_reset(int arglist){
E = stack[0];
S = 0;
C = 0;
A = 0;
P = 0;
return(makeT());
}
//-----------------------------
void initcell(void){
int addr,addr1;
for(addr=0; addr <= HEAPSIZE; addr++){
heap[addr].flag = FRE;
heap[addr].cdr = addr+1;
}
H = 0;
F = HEAPSIZE;
//0番地はnil、環境レジスタを設定する。初期環境
E = makeNIL();
assocsym(makeNIL(),makeNIL());
assocsym(makeT(),makeT());
S = 0;
A = 0;
}
//--FSUBR-----------
int f_setq(int arglist){
int arg1,arg2;
checkarg(LEN2_TEST, "setq", arglist);
checkarg(SYMBOL_TEST, "setq", car(arglist));
arg1 = car(arglist);
arg2 = eval(cadr(arglist));
bindsym(arg1,arg2);
return(makeT());
}
int f_register(int arglist){
checkarg(LEN0_TEST, "reg", arglist);
printf("H(heap) = %d\n", H);
printf("F(free) = %d\n", F);
printf("E(environment) = %d\n", E);
printf("S(stack) = %d\n", S);
printf("C(consume of S) = %d\n", C);
printf("A(arg-stack) = %d\n", A);
printf("P(on ctrl+c) = %d\n", P);
return(makeT());
}
int f_defun(int arglist){
int arg1,arg2;
checkarg(LEN3_TEST, "defun", arglist);
checkarg(SYMBOL_TEST, "defun", car(arglist));
checkarg(LIST_TEST, "defun", cadr(arglist));
checkarg(LIST_TEST, "defun" ,caddr(arglist));
arg1 = car(arglist);
arg2 = cdr(arglist);
bindfunc(GET_NAME(arg1),LAMBDA,arg2);
return(makeT());
}
int f_eqgreater(int arglist){
int num1,num2;
checkarg(LEN2_TEST, ">=", arglist);
checkarg(NUMLIST_TEST, ">=", arglist);
num1 = GET_NUMBER(car(arglist));
num2 = GET_NUMBER(cadr(arglist));
if(num1 >= num2)
return(makeT());
else
return(makeNIL());
}
int f_smaller(int arglist){
int num1,num2;
checkarg(LEN2_TEST, "<", arglist);
checkarg(NUMLIST_TEST, "<", arglist);
num1 = GET_NUMBER(car(arglist));
num2 = GET_NUMBER(cadr(arglist));
if(num1 < num2)
return(makeT());
else
return(makeNIL());
}
Tseries *
mk_cheby(projUV a, projUV b, double res, projUV *resid, projUV (*func)(projUV),
int nu, int nv, int power) {
int j, i, nru, nrv, *ncu, *ncv;
Tseries *Ts = 0;
projUV **w;
double cutres;
if (!(w = (projUV **)vector2(nu, nv, sizeof(projUV))) ||
!(ncu = (int *)vector1(nu + nv, sizeof(int))))
return 0;
ncv = ncu + nu;
if (!bchgen(a, b, nu, nv, w, func)) {
projUV *s;
double *p;
/* analyse coefficients and adjust until residual OK */
cutres = res;
for (i = 4; i ; --i) {
eval(w, nu, nv, cutres, resid);
if (resid->u < res && resid->v < res)
break;
cutres *= 0.5;
}
if (i <= 0) /* warn of too many tries */
resid->u = - resid->u;
/* apply cut resolution and set pointers */
nru = nrv = 0;
for (j = 0; j < nu; ++j) {
ncu[j] = ncv[j] = 0; /* clear column maxes */
for (s = w[j], i = 0; i < nv; ++i, ++s) {
if (fabs(s->u) < cutres) /* < resolution ? */
s->u = 0.; /* clear coefficient */
else
ncu[j] = i + 1; /* update column max */
if (fabs(s->v) < cutres) /* same for v coef's */
s->v = 0.;
else
ncv[j] = i + 1;
}
if (ncu[j]) nru = j + 1; /* update row max */
if (ncv[j]) nrv = j + 1;
}
if (power) { /* convert to bivariate power series */
if (!bch2bps(a, b, w, nu, nv))
goto error;
/* possible change in some row counts, so readjust */
nru = nrv = 0;
for (j = 0; j < nu; ++j) {
ncu[j] = ncv[j] = 0; /* clear column maxes */
for (s = w[j], i = 0; i < nv; ++i, ++s) {
if (s->u)
ncu[j] = i + 1; /* update column max */
if (s->v)
ncv[j] = i + 1;
}
if (ncu[j]) nru = j + 1; /* update row max */
if (ncv[j]) nrv = j + 1;
}
Ts = makeT(nru, nrv);
if (Ts) {
Ts->a = a;
Ts->b = b;
Ts->mu = nru - 1;
Ts->mv = nrv - 1;
Ts->power = 1;
for (i = 0; i < nru; ++i) /* store coefficient rows for u */
Ts->cu[i].m = ncu[i];
if (Ts->cu[i].m) {
if ((p = Ts->cu[i].c =
(double *)pj_malloc(sizeof(double) * ncu[i]))) {
for (j = 0; j < ncu[i]; ++j) {
*p++ = (w[i] + j)->u;
}
} else {
goto error;
}
}
for (i = 0; i < nrv; ++i) /* same for v */
Ts->cv[i].m = ncv[i];
if (Ts->cv[i].m) {
if ((p = Ts->cv[i].c =
(double *)pj_malloc(sizeof(double) * ncv[i]))) {
for (j = 0; j < ncv[i]; ++j) {
*p++ = (w[i] + j)->v;
}
} else {
goto error;
}
}
}
} else if ((Ts = makeT(nru, nrv))) {
/* else make returned Chebyshev coefficient structure */
Ts->mu = nru - 1; /* save row degree */
Ts->mv = nrv - 1;
Ts->a.u = a.u + b.u; /* set argument scaling */
Ts->a.v = a.v + b.v;
Ts->b.u = 1. / (b.u - a.u);
Ts->b.v = 1. / (b.v - a.v);
Ts->power = 0;
for (i = 0; i < nru; ++i) /* store coefficient rows for u */
Ts->cu[i].m = ncu[i];
if (Ts->cu[i].m) {
if ((p = Ts->cu[i].c =
(double *)pj_malloc(sizeof(double) * ncu[i]))) {
for (j = 0; j < ncu[i]; ++j)
*p++ = (w[i] + j)->u;
} else {
goto error;
}
}
for (i = 0; i < nrv; ++i) /* same for v */
Ts->cv[i].m = ncv[i];
if (Ts->cv[i].m) {
if ((p = Ts->cv[i].c =
(double *)pj_malloc(sizeof(double) * ncv[i]))) {
for (j = 0; j < ncv[i]; ++j)
*p++ = (w[i] + j)->v;
} else {
goto error;
}
}
} else
goto error;
}
goto gohome;
error:
if (Ts) { /* pj_dalloc up possible allocations */
for (i = 0; i <= Ts->mu; ++i)
if (Ts->cu[i].c)
pj_dalloc(Ts->cu[i].c);
for (i = 0; i <= Ts->mv; ++i)
if (Ts->cv[i].c)
pj_dalloc(Ts->cv[i].c);
pj_dalloc(Ts);
}
Ts = 0;
gohome:
freev2((void **) w, nu);
pj_dalloc(ncu);
return Ts;
}
int f_princ(int arglist){
checkarg(LEN1_TEST, "princ", arglist);
print(car(arglist));
return(makeT());
}
int f_gbc(int arglist){
gbc();
return(makeT());
}
int f_listp(int arglist){
if(listp(car(arglist)))
return(makeT());
else
return(makeNIL());
}
int f_numberp(int arglist){
if(numberp(car(arglist)))
return(makeT());
else
return(makeNIL());
}
int f_symbolp(int arglist){
if(symbolp(car(arglist)))
return(makeT());
else
return(makeNIL());
}
