![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to puref.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / parse|
Return to puref.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / parse |
1.1 ! noro 1: /* $OpenXM: OpenXM/src/asir99/parse/puref.c,v 1.1.1.1 1999/11/10 08:12:34 noro Exp $ */
! 2: #include "ca.h"
! 3: #include "parse.h"
! 4:
! 5: NODE pflist;
! 6:
! 7: void searchpf(name,fp)
! 8: char *name;
! 9: FUNC *fp;
! 10: {
! 11: NODE node;
! 12: PF pf;
! 13: FUNC t;
! 14:
! 15: for ( node = pflist; node; node = NEXT(node) )
! 16: if ( !strcmp(name,((PF)node->body)->name) ) {
! 17: pf = (PF)node->body;
! 18: *fp = t = (FUNC)MALLOC(sizeof(struct oFUNC));
! 19: t->name = name; t->id = A_PURE; t->argc = pf->argc;
! 20: t->f.puref = pf;
! 21: return;
! 22: }
! 23: *fp = 0;
! 24: }
! 25:
! 26: void searchc(name,fp)
! 27: char *name;
! 28: FUNC *fp;
! 29: {
! 30: NODE node;
! 31: PF pf;
! 32: FUNC t;
! 33:
! 34: for ( node = pflist; node; node = NEXT(node) )
! 35: if ( !strcmp(name,((PF)node->body)->name)
! 36: && !((PF)node->body)->argc ) {
! 37: pf = (PF)node->body;
! 38: *fp = t = (FUNC)MALLOC(sizeof(struct oFUNC));
! 39: t->name = name; t->id = A_PURE; t->argc = pf->argc;
! 40: t->f.puref = pf;
! 41: return;
! 42: }
! 43: *fp = 0;
! 44: }
! 45:
! 46: void mkpf(name,body,argc,args,parif,libmf,simp,pfp)
! 47: char *name;
! 48: Obj body;
! 49: int argc;
! 50: V *args;
! 51: int (*parif)(),(*simp)();
! 52: double (*libmf)();
! 53: PF *pfp;
! 54: {
! 55: PF pf;
! 56: NODE node;
! 57:
! 58: NEWPF(pf); pf->name = name; pf->body = body;
! 59: pf->argc = argc; pf->args = args; pf->pari = parif; pf->simplify = simp;
! 60: pf->libm = libmf;
! 61: for ( node = pflist; node; node = NEXT(node) )
! 62: if ( !strcmp(((PF)BDY(node))->name,name) )
! 63: break;
! 64: if ( !node ) {
! 65: NEWNODE(node); NEXT(node) = pflist; pflist = node;
! 66: /* fprintf(stderr,"%s() defined.\n",name); */
! 67: } else
! 68: fprintf(stderr,"%s() redefined.\n",name);
! 69: BDY(node) = (pointer)pf; *pfp = pf;
! 70: }
! 71:
! 72: /*
! 73: create an instance of a pure function. args are given
! 74: as an array of V. So we have to create a P object for
! 75: each arg.
! 76: */
! 77:
! 78: void mkpfins(pf,args,vp)
! 79: PF pf;
! 80: V *args;
! 81: V *vp;
! 82: {
! 83: V v;
! 84: PFINS ins;
! 85: PFAD ad;
! 86: int i;
! 87: P t;
! 88:
! 89: NEWV(v); NAME(v) = 0; v->attr = (pointer)V_PF;
! 90: ins = (PFINS)MALLOC(sizeof(PF)+pf->argc*sizeof(struct oPFAD));
! 91: bzero((char *)ins,(int)(sizeof(PF)+pf->argc*sizeof(struct oPFAD)));
! 92: ins->pf = pf;
! 93: v->priv = (pointer)ins;
! 94: for ( i = 0, ad = ins->ad; i < pf->argc; i++ ) {
! 95: ad[i].d = 0; MKV(args[i],t); ad[i].arg = (Obj)t;
! 96: }
! 97: appendpfins(v,vp);
! 98: }
! 99:
! 100: /* the same as above. Argements are given as an array of Obj */
! 101:
! 102: void _mkpfins(pf,args,vp)
! 103: PF pf;
! 104: Obj *args;
! 105: V *vp;
! 106: {
! 107: V v;
! 108: PFINS ins;
! 109: PFAD ad;
! 110: int i;
! 111:
! 112: NEWV(v); NAME(v) = 0; v->attr = (pointer)V_PF;
! 113: ins = (PFINS)MALLOC(sizeof(PF)+pf->argc*sizeof(struct oPFAD));
! 114: bzero((char *)ins,(int)(sizeof(PF)+pf->argc*sizeof(struct oPFAD)));
! 115: ins->pf = pf;
! 116: v->priv = (pointer)ins;
! 117: for ( i = 0, ad = ins->ad; i < pf->argc; i++ ) {
! 118: ad[i].d = 0; ad[i].arg = args[i];
! 119: }
! 120: appendpfins(v,vp);
! 121: }
! 122:
! 123: /* the same as above. darray is also given */
! 124:
! 125: void _mkpfins_with_darray(pf,args,darray,vp)
! 126: PF pf;
! 127: Obj *args;
! 128: int *darray;
! 129: V *vp;
! 130: {
! 131: V v;
! 132: PFINS ins;
! 133: PFAD ad;
! 134: int i;
! 135:
! 136: NEWV(v); NAME(v) = 0; v->attr = (pointer)V_PF;
! 137: ins = (PFINS)MALLOC(sizeof(PF)+pf->argc*sizeof(struct oPFAD));
! 138: bzero((char *)ins,(int)(sizeof(PF)+pf->argc*sizeof(struct oPFAD)));
! 139: ins->pf = pf;
! 140: v->priv = (pointer)ins;
! 141: for ( i = 0, ad = ins->ad; i < pf->argc; i++ ) {
! 142: ad[i].d = darray[i]; ad[i].arg = args[i];
! 143: }
! 144: appendpfins(v,vp);
! 145: }
! 146:
! 147: void appendpfins(v,vp)
! 148: V v;
! 149: V *vp;
! 150: {
! 151: PF fdef;
! 152: PFAD ad,tad;
! 153: NODE node;
! 154: int i;
! 155:
! 156: fdef = ((PFINS)v->priv)->pf; ad = ((PFINS)v->priv)->ad;
! 157: for ( node = fdef->ins; node; node = NEXT(node) ) {
! 158: for ( i = 0, tad = ((PFINS)((V)node->body)->priv)->ad;
! 159: i < fdef->argc; i++ )
! 160: if ( (ad[i].d != tad[i].d) || compr(CO,ad[i].arg,tad[i].arg) )
! 161: break;
! 162: if ( i == fdef->argc ) {
! 163: *vp = (V)node->body;
! 164: return;
! 165: }
! 166: }
! 167: NEWNODE(node); node->body = (pointer)v; NEXT(node) = fdef->ins;
! 168: fdef->ins = node; appendvar(CO,v); *vp = v;
! 169: }
! 170:
! 171: void duppfins(v,vp)
! 172: V v;
! 173: V *vp;
! 174: {
! 175: V tv;
! 176: PFINS tins;
! 177: int size;
! 178:
! 179: NEWV(tv); tv->name = v->name; tv->attr = v->attr;
! 180: size = sizeof(PF)+((PFINS)v->priv)->pf->argc*sizeof(struct oPFAD);
! 181: tins = (PFINS)MALLOC(size); bcopy((char *)v->priv,(char *)tins,size);
! 182: tv->priv = (pointer)tins;
! 183: *vp = tv;
! 184: }
! 185:
! 186: void derivvar(vl,pf,v,a)
! 187: VL vl;
! 188: V pf,v;
! 189: Obj *a;
! 190: {
! 191: Obj t,s,u,w,u1;
! 192: P p;
! 193: V tv,sv;
! 194: PF fdef;
! 195: PFAD ad;
! 196: int i,j;
! 197:
! 198: fdef = ((PFINS)pf->priv)->pf; ad = ((PFINS)pf->priv)->ad;
! 199: if ( fdef->deriv ) {
! 200: for ( t = 0, i = 0; i < fdef->argc; i++ ) {
! 201: derivr(vl,ad[i].arg,v,&s);
! 202: for ( j = 0, u = fdef->deriv[i]; j < fdef->argc; j++ ) {
! 203: substr(vl,0,u,fdef->args[j],ad[j].arg,&u1); u = u1;
! 204: }
! 205: mulr(vl,s,u,&w); addr(vl,t,w,&s); t = s;
! 206: }
! 207: *a = t;
! 208: } else {
! 209: for ( t = 0, i = 0; i < fdef->argc; i++ ) {
! 210: derivr(vl,ad[i].arg,v,&s);
! 211: duppfins(pf,&tv); (((PFINS)tv->priv)->ad)[i].d++;
! 212: appendpfins(tv,&sv);
! 213: MKV(sv,p); mulr(vl,s,(Obj)p,&w); addr(vl,t,w,&s); t = s;
! 214: }
! 215: *a = t;
! 216: }
! 217: }
! 218:
! 219: void derivr(vl,a,v,b)
! 220: VL vl;
! 221: V v;
! 222: Obj a,*b;
! 223: {
! 224: VL tvl,svl;
! 225: Obj r,s,t,u,nm,dn,dnm,ddn,m;
! 226:
! 227: if ( !a )
! 228: *b = 0;
! 229: else
! 230: switch ( OID(a) ) {
! 231: case O_N:
! 232: *b = 0; break;
! 233: case O_P:
! 234: clctvr(vl,a,&tvl);
! 235: for ( dnm = 0, svl = tvl; svl; svl = NEXT(svl) ) {
! 236: if ( svl->v == v ) {
! 237: pderivr(vl,a,v,&s); addr(vl,s,dnm,&u); dnm = u;
! 238: } else if ( (vid)svl->v->attr == V_PF ) {
! 239: pderivr(vl,a,svl->v,&s); derivvar(vl,svl->v,v,&r);
! 240: mulr(vl,s,r,&u); addr(vl,u,dnm,&s); dnm = s;
! 241: }
! 242: }
! 243: *b = (Obj)dnm; break;
! 244: case O_R:
! 245: clctvr(vl,a,&tvl);
! 246: nm = (Obj)NM((R)a); dn = (Obj)DN((R)a);
! 247: for ( dnm = ddn = 0, svl = tvl; svl; svl = NEXT(svl) ) {
! 248: if ( svl->v == v ) {
! 249: pderivr(vl,nm,v,&s); addr(vl,s,dnm,&u); dnm = u;
! 250: pderivr(vl,dn,v,&s); addr(vl,s,ddn,&u); ddn = u;
! 251: } else if ( (vid)svl->v->attr == V_PF ) {
! 252: pderivr(vl,nm,svl->v,&s); derivvar(vl,svl->v,v,&r);
! 253: mulr(vl,s,r,&u); addr(vl,u,dnm,&s); dnm = s;
! 254: pderivr(vl,dn,svl->v,&s); derivvar(vl,svl->v,v,&r);
! 255: mulr(vl,s,r,&u); addr(vl,u,ddn,&s); ddn = s;
! 256: }
! 257: }
! 258: mulr(vl,dnm,dn,&t); mulr(vl,ddn,nm,&s);
! 259: subr(vl,t,s,&u); reductr(vl,u,&t);
! 260: if ( !t )
! 261: *b = 0;
! 262: else {
! 263: mulp(vl,(P)dn,(P)dn,(P *)&m); divr(vl,t,m,b);
! 264: }
! 265: break;
! 266: }
! 267: }
! 268:
! 269: void substr(vl,partial,a,v,b,c)
! 270: VL vl;
! 271: int partial;
! 272: Obj a;
! 273: V v;
! 274: Obj b;
! 275: Obj *c;
! 276: {
! 277: Obj nm,dn,t;
! 278:
! 279: if ( !a )
! 280: *c = 0;
! 281: else {
! 282: switch ( OID(a) ) {
! 283: case O_N:
! 284: *c = a; break;
! 285: case O_P:
! 286: substpr(vl,partial,a,v,b,c); break;
! 287: case O_R:
! 288: substpr(vl,partial,(Obj)NM((R)a),v,b,&nm);
! 289: substpr(vl,partial,(Obj)DN((R)a),v,b,&dn);
! 290: divr(vl,nm,dn,&t); reductr(vl,t,c);
! 291: break;
! 292: default:
! 293: *c = 0; break;
! 294: }
! 295: }
! 296: }
! 297:
! 298: void substpr(vl,partial,p,v0,p0,pr)
! 299: VL vl;
! 300: int partial;
! 301: V v0;
! 302: Obj p;
! 303: Obj p0;
! 304: Obj *pr;
! 305: {
! 306: P x;
! 307: Obj t,m,c,s,a;
! 308: DCP dc;
! 309: Q d;
! 310: V v;
! 311: PF pf;
! 312: PFAD ad,tad;
! 313: PFINS tins;
! 314: int i;
! 315:
! 316: if ( !p )
! 317: *pr = 0;
! 318: else if ( NUM(p) )
! 319: *pr = (Obj)p;
! 320: else if ( (v = VR((P)p)) != v0 ) {
! 321: if ( !partial && ((vid)v->attr == V_PF) ) {
! 322: ad = ((PFINS)v->priv)->ad; pf = ((PFINS)v->priv)->pf;
! 323: tins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
! 324: tins->pf = pf;
! 325: for ( i = 0, tad = tins->ad; i < pf->argc; i++ ) {
! 326: tad[i].d = ad[i].d;
! 327: substr(vl,partial,ad[i].arg,v0,p0,&tad[i].arg);
! 328: }
! 329: simplify_ins(tins,(Obj *)&x);
! 330: } else
! 331: MKV(VR((P)p),x);
! 332: for ( c = 0, dc = DC((P)p); dc; dc = NEXT(dc) ) {
! 333: substpr(vl,partial,(Obj)COEF(dc),v0,p0,&t);
! 334: if ( DEG(dc) ) {
! 335: pwrp(vl,x,DEG(dc),(P *)&s); mulr(vl,s,t,&m);
! 336: addr(vl,m,c,&a); c = a;
! 337: } else {
! 338: addr(vl,t,c,&a); c = a;
! 339: }
! 340: }
! 341: *pr = c;
! 342: } else {
! 343: dc = DC((P)p);
! 344: if ( !partial )
! 345: substpr(vl,partial,(Obj)COEF(dc),v0,p0,&c);
! 346: else
! 347: c = (Obj)COEF(dc);
! 348: for ( d = DEG(dc), dc = NEXT(dc); dc; d = DEG(dc), dc = NEXT(dc) ) {
! 349: subq(d,DEG(dc),(Q *)&t); pwrr(vl,p0,t,&s); mulr(vl,s,c,&m);
! 350: if ( !partial )
! 351: substpr(vl,partial,(Obj)COEF(dc),v0,p0,&t);
! 352: else
! 353: t = (Obj)COEF(dc);
! 354: addr(vl,m,t,&c);
! 355: }
! 356: if ( d ) {
! 357: pwrr(vl,p0,(Obj)d,&t); mulr(vl,t,c,&m);
! 358: c = m;
! 359: }
! 360: *pr = c;
! 361: }
! 362: }
! 363:
! 364: void evalr(vl,a,prec,c)
! 365: VL vl;
! 366: Obj a;
! 367: int prec;
! 368: Obj *c;
! 369: {
! 370: Obj nm,dn;
! 371:
! 372: if ( !a )
! 373: *c = 0;
! 374: else {
! 375: switch ( OID(a) ) {
! 376: case O_N:
! 377: *c = a; break;
! 378: case O_P:
! 379: evalp(vl,(P)a,prec,(P *)c); break;
! 380: case O_R:
! 381: evalp(vl,NM((R)a),prec,(P *)&nm); evalp(vl,DN((R)a),prec,(P *)&dn);
! 382: divr(vl,nm,dn,c);
! 383: break;
! 384: default:
! 385: error("evalr : not implemented"); break;
! 386: }
! 387: }
! 388: }
! 389:
! 390: void evalp(vl,p,prec,pr)
! 391: VL vl;
! 392: P p;
! 393: int prec;
! 394: P *pr;
! 395: {
! 396: P t;
! 397: DCP dc,dcr0,dcr;
! 398: Obj u;
! 399:
! 400: if ( !p || NUM(p) )
! 401: *pr = p;
! 402: else {
! 403: for ( dcr0 = 0, dc = DC((P)p); dc; dc = NEXT(dc) ) {
! 404: evalp(vl,COEF(dc),prec,&t);
! 405: if ( t ) {
! 406: NEXTDC(dcr0,dcr); DEG(dcr) = DEG(dc); COEF(dcr) = t;
! 407: }
! 408: }
! 409: if ( !dcr0 ) {
! 410: *pr = 0; return;
! 411: } else {
! 412: NEXT(dcr) = 0; MKP(VR(p),dcr0,t);
! 413: }
! 414: if ( NUM(t) || (VR(t) != VR(p)) || ((vid)VR(p)->attr != V_PF) ) {
! 415: *pr = t; return;
! 416: } else {
! 417: evalv(vl,VR(p),prec,&u); substr(vl,1,(Obj)t,VR(p),u,(Obj *)pr);
! 418: }
! 419: }
! 420: }
! 421:
! 422: void evalv(vl,v,prec,rp)
! 423: VL vl;
! 424: V v;
! 425: int prec;
! 426: Obj *rp;
! 427: {
! 428: PFINS ins,tins;
! 429: PFAD ad,tad;
! 430: PF pf;
! 431: P t;
! 432: int i;
! 433:
! 434: if ( (vid)v->attr != V_PF ) {
! 435: MKV(v,t); *rp = (Obj)t;
! 436: } else {
! 437: ins = (PFINS)v->priv; ad = ins->ad; pf = ins->pf;
! 438: tins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
! 439: tins->pf = pf;
! 440: for ( i = 0, tad = tins->ad; i < pf->argc; i++ ) {
! 441: tad[i].d = ad[i].d; evalr(vl,ad[i].arg,prec,&tad[i].arg);
! 442: }
! 443: evalins(tins,prec,rp);
! 444: }
! 445: }
! 446:
! 447: void evalins(ins,prec,rp)
! 448: PFINS ins;
! 449: int prec;
! 450: Obj *rp;
! 451: {
! 452: PF pf;
! 453: PFAD ad;
! 454: int i;
! 455: Q q;
! 456: V v;
! 457: P x;
! 458: NODE n0,n;
! 459:
! 460: pf = ins->pf; ad = ins->ad;
! 461: for ( i = 0; i < pf->argc; i++ )
! 462: if ( ad[i].d || (ad[i].arg && !NUM(ad[i].arg)) )
! 463: break;
! 464: if ( (i != pf->argc) || !pf->pari ) {
! 465: instov(ins,&v); MKV(v,x); *rp = (Obj)x;
! 466: } else {
! 467: for ( n0 = 0, i = 0; i < pf->argc; i++ ) {
! 468: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
! 469: }
! 470: if ( prec ) {
! 471: NEXTNODE(n0,n); STOQ(prec,q); BDY(n) = (pointer)q;
! 472: }
! 473: if ( n0 )
! 474: NEXT(n) = 0;
! 475: (*pf->pari)(n0,rp);
! 476: }
! 477: }
! 478:
! 479: void devalins(PFINS,Obj *);
! 480: void devalv(VL,V,Obj *);
! 481: void devalp(VL,P,P *);
! 482: void devalr(VL,Obj,Obj *);
! 483:
! 484: void devalr(vl,a,c)
! 485: VL vl;
! 486: Obj a;
! 487: Obj *c;
! 488: {
! 489: Obj nm,dn;
! 490: double d;
! 491: Real r;
! 492:
! 493: if ( !a )
! 494: *c = 0;
! 495: else {
! 496: switch ( OID(a) ) {
! 497: case O_N:
! 498: d = ToReal(a);
! 499: MKReal(d,r);
! 500: *c = (Obj)r;
! 501: break;
! 502: case O_P:
! 503: devalp(vl,(P)a,(P *)c); break;
! 504: case O_R:
! 505: devalp(vl,NM((R)a),(P *)&nm);
! 506: devalp(vl,DN((R)a),(P *)&dn);
! 507: divr(vl,nm,dn,c);
! 508: break;
! 509: default:
! 510: error("devalr : not implemented"); break;
! 511: }
! 512: }
! 513: }
! 514:
! 515: void devalp(vl,p,pr)
! 516: VL vl;
! 517: P p;
! 518: P *pr;
! 519: {
! 520: P t;
! 521: DCP dc,dcr0,dcr;
! 522: Obj u,s;
! 523: double d;
! 524: Real r;
! 525:
! 526: if ( !p || NUM(p) ) {
! 527: d = ToReal(p);
! 528: MKReal(d,r);
! 529: *pr = (P)r;
! 530: } else {
! 531: for ( dcr0 = 0, dc = DC((P)p); dc; dc = NEXT(dc) ) {
! 532: devalp(vl,COEF(dc),&t);
! 533: if ( t ) {
! 534: NEXTDC(dcr0,dcr); DEG(dcr) = DEG(dc); COEF(dcr) = t;
! 535: }
! 536: }
! 537: if ( !dcr0 )
! 538: *pr = 0;
! 539: else {
! 540: NEXT(dcr) = 0; MKP(VR(p),dcr0,t);
! 541: if ( NUM(t) ) {
! 542: d = ToReal((Num)t);
! 543: MKReal(d,r);
! 544: *pr = (P)r;
! 545: } else if ( (VR(t) != VR(p)) || (VR(p)->attr != (pointer)V_PF) )
! 546: *pr = t;
! 547: else {
! 548: devalv(vl,VR(p),&u);
! 549: substr(vl,1,(Obj)t,VR(p),u,&s);
! 550: if ( s && NUM(s) ) {
! 551: d = ToReal((Num)s);
! 552: MKReal(d,r);
! 553: *pr = (P)r;
! 554: } else
! 555: *pr = (P)s;
! 556: }
! 557: }
! 558: }
! 559: }
! 560:
! 561: void devalv(vl,v,rp)
! 562: VL vl;
! 563: V v;
! 564: Obj *rp;
! 565: {
! 566: PFINS ins,tins;
! 567: PFAD ad,tad;
! 568: PF pf;
! 569: P t;
! 570: Obj s;
! 571: int i;
! 572:
! 573: if ( (vid)v->attr != V_PF ) {
! 574: MKV(v,t); *rp = (Obj)t;
! 575: } else {
! 576: ins = (PFINS)v->priv; ad = ins->ad; pf = ins->pf;
! 577: tins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
! 578: tins->pf = pf;
! 579: for ( i = 0, tad = tins->ad; i < pf->argc; i++ ) {
! 580: tad[i].d = ad[i].d; devalr(vl,ad[i].arg,&tad[i].arg);
! 581: }
! 582: devalins(tins,rp);
! 583: }
! 584: }
! 585:
! 586: void devalins(ins,rp)
! 587: PFINS ins;
! 588: Obj *rp;
! 589: {
! 590: PF pf;
! 591: PFAD ad;
! 592: int i;
! 593: Real r;
! 594: double d;
! 595: Q q;
! 596: V v;
! 597: P x;
! 598:
! 599: pf = ins->pf; ad = ins->ad;
! 600: for ( i = 0; i < pf->argc; i++ )
! 601: if ( ad[i].d || (ad[i].arg && !NUM(ad[i].arg)) )
! 602: break;
! 603: if ( (i != pf->argc) || !pf->libm ) {
! 604: instov(ins,&v); MKV(v,x); *rp = (Obj)x;
! 605: } else {
! 606: switch ( pf->argc ) {
! 607: case 0:
! 608: d = (*pf->libm)(); break;
! 609: case 1:
! 610: d = (*pf->libm)(ToReal(ad[0].arg)); break;
! 611: case 2:
! 612: d = (*pf->libm)(ToReal(ad[0].arg),ToReal(ad[1].arg)); break;
! 613: case 3:
! 614: d = (*pf->libm)(ToReal(ad[0].arg),ToReal(ad[1].arg),
! 615: ToReal(ad[2].arg)); break;
! 616: case 4:
! 617: d = (*pf->libm)(ToReal(ad[0].arg),ToReal(ad[1].arg),
! 618: ToReal(ad[2].arg),ToReal(ad[3].arg)); break;
! 619: default:
! 620: error("devalv : not supported");
! 621: }
! 622: MKReal(d,r); *rp = (Obj)r;
! 623: }
! 624: }
! 625:
! 626: void simplify_ins(ins,rp)
! 627: PFINS ins;
! 628: Obj *rp;
! 629: {
! 630: V v;
! 631: P t;
! 632:
! 633: if ( ins->pf->simplify )
! 634: (*ins->pf->simplify)(ins,rp);
! 635: else {
! 636: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
! 637: }
! 638: }
! 639:
! 640: void instov(ins,vp)
! 641: PFINS ins;
! 642: V *vp;
! 643: {
! 644: V v;
! 645:
! 646: NEWV(v); NAME(v) = 0;
! 647: v->attr = (pointer)V_PF; v->priv = (pointer)ins;
! 648: appendpfins(v,vp);
! 649: }
! 650:
! 651: void substfr(vl,a,u,f,c)
! 652: VL vl;
! 653: Obj a;
! 654: PF u,f;
! 655: Obj *c;
! 656: {
! 657: Obj nm,dn;
! 658:
! 659: if ( !a )
! 660: *c = 0;
! 661: else {
! 662: switch ( OID(a) ) {
! 663: case O_N:
! 664: *c = a; break;
! 665: case O_P:
! 666: substfp(vl,a,u,f,c); break;
! 667: case O_R:
! 668: substfp(vl,(Obj)NM((R)a),u,f,&nm); substfp(vl,(Obj)DN((R)a),u,f,&dn);
! 669: divr(vl,nm,dn,c);
! 670: break;
! 671: default:
! 672: error("substfr : not implemented"); break;
! 673: }
! 674: }
! 675: }
! 676:
! 677: void substfp(vl,p,u,f,pr)
! 678: VL vl;
! 679: Obj p;
! 680: PF u,f;
! 681: Obj *pr;
! 682: {
! 683: V v;
! 684: DCP dc;
! 685: Obj a,c,m,s,t,p0;
! 686: Q d;
! 687: P x;
! 688:
! 689: if ( !p )
! 690: *pr = 0;
! 691: else if ( NUM(p) )
! 692: *pr = (Obj)p;
! 693: else {
! 694: v = VR((P)p); dc = DC((P)p);
! 695: if ( (int)v->attr != V_PF ) {
! 696: MKV(VR((P)p),x);
! 697: for ( c = 0; dc; dc = NEXT(dc) ) {
! 698: substfp(vl,(Obj)COEF(dc),u,f,&t);
! 699: if ( DEG(dc) ) {
! 700: pwrp(vl,x,DEG(dc),(P *)&s); mulr(vl,s,t,&m);
! 701: addr(vl,m,c,&a); c = a;
! 702: } else {
! 703: addr(vl,t,c,&a); c = a;
! 704: }
! 705: }
! 706: } else {
! 707: substfv(vl,v,u,f,&p0);
! 708: substfp(vl,(Obj)COEF(dc),u,f,&c);
! 709: for ( d = DEG(dc), dc = NEXT(dc); dc; d = DEG(dc), dc = NEXT(dc) ) {
! 710: subq(d,DEG(dc),(Q *)&t); pwrr(vl,p0,t,&s); mulr(vl,s,c,&m);
! 711: substfp(vl,(Obj)COEF(dc),u,f,&t); addr(vl,m,t,&c);
! 712: }
! 713: if ( d ) {
! 714: pwrr(vl,p0,(Obj)d,&t); mulr(vl,t,c,&m);
! 715: c = m;
! 716: }
! 717: }
! 718: *pr = c;
! 719: }
! 720: }
! 721:
! 722: void substfv(vl,v,u,f,c)
! 723: VL vl;
! 724: V v;
! 725: PF u,f;
! 726: Obj *c;
! 727: {
! 728: P t;
! 729: Obj r,s,w;
! 730: int i,j;
! 731: PFINS ins,tins;
! 732: PFAD ad,tad;
! 733:
! 734: ins = (PFINS)v->priv; ad = ins->ad;
! 735: if ( ins->pf == u ) {
! 736: if ( u->argc != f->argc )
! 737: error("substfv : argument mismatch");
! 738: if ( !f->body ) {
! 739: mkpfins(f,f->args,&v); MKV(v,t); r = (Obj)t;
! 740: } else
! 741: r = f->body;
! 742: for ( i = 0; i < f->argc; i++ )
! 743: for ( j = 0; j < ad[i].d; j++ ) {
! 744: derivr(vl,r,f->args[i],&s); r = s;
! 745: }
! 746: for ( i = 0; i < f->argc; i++ ) {
! 747: substfr(vl,ad[i].arg,u,f,&w);
! 748: substr(vl,0,r,f->args[i],w,&s); r = s;
! 749: }
! 750: *c = r;
! 751: } else {
! 752: tins = (PFINS)MALLOC(sizeof(PF)+f->argc*sizeof(struct oPFAD));
! 753: tins->pf = ins->pf; tad = tins->ad;
! 754: for ( i = 0; i < f->argc; i++ ) {
! 755: tad[i].d = ad[i].d; substfr(vl,ad[i].arg,u,f,&tad[i].arg);
! 756: }
! 757: instov(tins,&v); MKV(v,t); *c = (Obj)t;
! 758: }
! 759: }