![[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: }