Annotation of OpenXM_contrib2/asir2000/builtin/pf.c, Revision 1.10
1.2 noro 1: /*
2: * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED
3: * All rights reserved.
4: *
5: * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,
6: * non-exclusive and royalty-free license to use, copy, modify and
7: * redistribute, solely for non-commercial and non-profit purposes, the
8: * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and
9: * conditions of this Agreement. For the avoidance of doubt, you acquire
10: * only a limited right to use the SOFTWARE hereunder, and FLL or any
11: * third party developer retains all rights, including but not limited to
12: * copyrights, in and to the SOFTWARE.
13: *
14: * (1) FLL does not grant you a license in any way for commercial
15: * purposes. You may use the SOFTWARE only for non-commercial and
16: * non-profit purposes only, such as academic, research and internal
17: * business use.
18: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
19: * international copyright treaties. If you make copies of the SOFTWARE,
20: * with or without modification, as permitted hereunder, you shall affix
21: * to all such copies of the SOFTWARE the above copyright notice.
22: * (3) An explicit reference to this SOFTWARE and its copyright owner
23: * shall be made on your publication or presentation in any form of the
24: * results obtained by use of the SOFTWARE.
25: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.3 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.2 noro 27: * for such modification or the source code of the modified part of the
28: * SOFTWARE.
29: *
30: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
31: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
32: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
33: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
34: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
35: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
36: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
37: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
38: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
39: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
40: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
41: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
42: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
43: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
44: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
45: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
46: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
47: *
1.10 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.9 2004/12/17 03:09:08 noro Exp $
1.2 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "math.h"
52: #include "parse.h"
53: #if 0
54: #include <alloca.h>
55: #endif
56:
57: double const_pi(),const_e();
58:
59: void make_ihyp(void);
60: void make_hyp(void);
61: void make_itri(void);
62: void make_tri(void);
63: void make_exp(void);
64: void simplify_pow(PFINS,Obj *);
65:
1.10 ! noro 66: void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(),Pfunargs_ext();
1.1 noro 67: void Pregister_handler();
1.4 noro 68: void Peval_quote();
1.7 noro 69: void Pmapat();
1.9 noro 70: void Padd_handler();
71: void Plist_handler();
72: void Pclear_handler();
1.1 noro 73:
74: struct ftab puref_tab[] = {
1.7 noro 75: {"mapat",Pmapat,-99999999},
1.1 noro 76: {"functor",Pfunctor,1},
77: {"args",Pargs,1},
78: {"funargs",Pfunargs,1},
1.10 ! noro 79: {"funargs_ext",Pfunargs_ext,1},
1.1 noro 80: {"register_handler",Pregister_handler,1},
1.9 noro 81: {"add_handler",Padd_handler,2},
82: {"list_handler",Plist_handler,1},
83: {"clear_handler",Pclear_handler,1},
1.1 noro 84: {"call",Pcall,2},
85: {"vtype",Pvtype,1},
86: {"deval",Pdeval,1},
1.4 noro 87: {"eval_quote",Peval_quote,1},
1.1 noro 88: {0,0,0},
89: };
90:
1.6 ohara 91: #if defined(PARI)
1.1 noro 92: int p_pi(),p_e();
93: int p_log(),p_exp(),p_pow();
94: int p_sin(),p_cos(),p_tan(),p_asin(),p_acos(),p_atan();
95: int p_sinh(),p_cosh(),p_tanh(),p_asinh(),p_acosh(),p_atanh();
96: #else
97: int p_pi,p_e;
98: int p_log,p_exp,p_pow;
99: int p_sin,p_cos,p_tan,p_asin,p_acos,p_atan;
100: int p_sinh,p_cosh,p_tanh,p_asinh,p_acosh,p_atanh;
101: #endif
102:
103: static V *uarg,*darg;
104: static P x,y;
105: static PF pidef,edef;
106: static PF logdef,expdef,powdef;
107: static PF sindef,cosdef,tandef;
108: static PF asindef,acosdef,atandef;
109: static PF sinhdef,coshdef,tanhdef;
110: static PF asinhdef,acoshdef,atanhdef;
111:
112: #define OALLOC(p,n) ((p)=(Obj *)CALLOC((n),sizeof(Obj)))
113:
114: double const_pi() { return 3.14159265358979323846264338327950288; }
115: double const_e() { return 2.718281828459045235360287471352662497; }
116:
117: void pf_init() {
118: uarg = (V *)CALLOC(1,sizeof(V));
119: uarg[0] = &oVAR[26]; MKV(uarg[0],x);
120:
121: darg = (V *)CALLOC(2,sizeof(V));
122: darg[0] = &oVAR[26];
123: darg[1] = &oVAR[27]; MKV(darg[1],y);
124:
125: mkpf("@pi",0,0,0,(int (*)())p_pi,const_pi,0,&pidef);
126: mkpf("@e",0,0,0,(int (*)())p_e,const_e,0,&edef);
127:
128: mkpf("log",0,1,uarg,(int (*)())p_log,log,0,&logdef);
129: mkpf("exp",0,1,uarg,(int (*)())p_exp,exp,0,&expdef);
130: mkpf("pow",0,2,darg,(int (*)())p_pow,pow,(int (*)())simplify_pow,&powdef);
131:
132: mkpf("sin",0,1,uarg,(int (*)())p_sin,sin,0,&sindef);
133: mkpf("cos",0,1,uarg,(int (*)())p_cos,cos,0,&cosdef);
134: mkpf("tan",0,1,uarg,(int (*)())p_tan,tan,0,&tandef);
135: mkpf("asin",0,1,uarg,(int (*)())p_asin,asin,0,&asindef);
136: mkpf("acos",0,1,uarg,(int (*)())p_acos,acos,0,&acosdef);
137: mkpf("atan",0,1,uarg,(int (*)())p_atan,atan,0,&atandef);
138:
139: mkpf("sinh",0,1,uarg,(int (*)())p_sinh,sinh,0,&sinhdef);
140: mkpf("cosh",0,1,uarg,(int (*)())p_cosh,cosh,0,&coshdef);
141: mkpf("tanh",0,1,uarg,(int (*)())p_tanh,tanh,0,&tanhdef);
142: #if !defined(VISUAL)
143: mkpf("asinh",0,1,uarg,(int (*)())p_asinh,asinh,0,&asinhdef);
144: mkpf("acosh",0,1,uarg,(int (*)())p_acosh,acosh,0,&acoshdef);
145: mkpf("atanh",0,1,uarg,(int (*)())p_atanh,atanh,0,&atanhdef);
146: #endif
147: make_exp();
148: make_tri();
149: make_itri();
150: make_hyp();
151: #if !defined(VISUAL)
152: make_ihyp();
153: #endif
154: }
155:
156: void make_exp() {
157: V v;
158: P u,vexp,vlog,vpow;
159: Obj *args;
160:
161: mkpfins(expdef,uarg,&v); MKV(v,vexp);
162: mkpfins(powdef,darg,&v); MKV(v,vpow);
163: mkpfins(logdef,uarg,&v); MKV(v,vlog);
164:
165: /* d/dx(log(x)) = 1/x */
166: OALLOC(logdef->deriv,1); divr(CO,(Obj)ONE,(Obj)x,&logdef->deriv[0]);
167:
168: /* d/dx(exp(x)) = exp(x) */
169: OALLOC(expdef->deriv,1); expdef->deriv[0] = (Obj)vexp;
170:
171: /* d/dy(x^y) = log(x)*x^y */
172: OALLOC(powdef->deriv,2); mulp(CO,vpow,vlog,(P *)&powdef->deriv[1]);
173:
174: /* d/dx(x^y) = y*x^(y-1) */
175: args = (Obj *)ALLOCA(2*sizeof(Obj));
176: args[0] = (Obj)x; subp(CO,y,(P)ONE,(P *)&args[1]);
177: _mkpfins(powdef,args,&v); MKV(v,u);
178: mulr(CO,(Obj)u,(Obj)y,&powdef->deriv[0]);
179: }
180:
181: void make_tri() {
182: V v;
183: P vcos,vsin,vtan,t;
184:
185: mkpfins(cosdef,uarg,&v); MKV(v,vcos);
186: mkpfins(sindef,uarg,&v); MKV(v,vsin);
187: mkpfins(tandef,uarg,&v); MKV(v,vtan);
188:
189: /* d/dx(sin(x)) = cos(x) */
190: OALLOC(sindef->deriv,1); sindef->deriv[0] = (Obj)vcos;
191:
192: /* d/dx(cos(x)) = -sin(x) */
193: OALLOC(cosdef->deriv,1); chsgnp(vsin,(P *)&cosdef->deriv[0]);
194:
195: /* d/dx(tan(x)) = 1+tan(x)^2 */
196: OALLOC(tandef->deriv,1);
197: mulr(CO,(Obj)vtan,(Obj)vtan,(Obj *)&t); addp(CO,(P)ONE,t,(P *)&tandef->deriv[0]);
198: }
199:
200: void make_itri() {
201: P t,xx;
202: Q mtwo;
203: V v;
204: Obj *args;
205:
206: /* d/dx(asin(x)) = (1-x^2)^(-1/2) */
207: OALLOC(asindef->deriv,1);
208: args = (Obj *)ALLOCA(2*sizeof(Obj));
209: mulp(CO,x,x,&xx); subp(CO,(P)ONE,xx,(P *)&args[0]);
210: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
211: _mkpfins(powdef,args,&v); MKV(v,t);
212: asindef->deriv[0] = (Obj)t;
213:
214: /* d/dx(acos(x)) = -(1-x^2)^(-1/2) */
215: OALLOC(acosdef->deriv,1); chsgnp((P)asindef->deriv[0],(P *)&acosdef->deriv[0]);
216:
217: /* d/dx(atan(x)) = 1/(x^2+1) */
218: OALLOC(atandef->deriv,1);
219: addp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atandef->deriv[0]);
220: }
221:
222: void make_hyp() {
223: V v;
224: P vcosh,vsinh,vtanh,t;
225:
226: mkpfins(coshdef,uarg,&v); MKV(v,vcosh);
227: mkpfins(sinhdef,uarg,&v); MKV(v,vsinh);
228: mkpfins(tanhdef,uarg,&v); MKV(v,vtanh);
229:
230: /* d/dx(sinh(x)) = cosh(x) */
231: OALLOC(sinhdef->deriv,1); sinhdef->deriv[0] = (Obj)vcosh;
232:
233: /* d/dx(cosh(x)) = sinh(x) */
234: OALLOC(coshdef->deriv,1); coshdef->deriv[0] = (Obj)vsinh;
235:
236: /* d/dx(tanh(x)) = 1-tanh(x)^2 */
237: OALLOC(tanhdef->deriv,1);
238: mulr(CO,(Obj)vtanh,(Obj)vtanh,(Obj *)&t); subp(CO,(P)ONE,t,(P *)&tanhdef->deriv[0]);
239: }
240:
241: void make_ihyp() {
242: P t,xx;
243: Q mtwo;
244: V v;
245: Obj *args;
246:
247: /* d/dx(asinh(x)) = (1+x^2)^(-1/2) */
248: OALLOC(asinhdef->deriv,1);
249: args = (Obj *)ALLOCA(2*sizeof(Obj));
250: mulp(CO,x,x,&xx); addp(CO,(P)ONE,xx,(P *)&args[0]);
251: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
252: _mkpfins(powdef,args,&v); MKV(v,t);
253: asinhdef->deriv[0] = (Obj)t;
254:
255: /* d/dx(acosh(x)) = (x^2-1)^(-1/2) */
256: OALLOC(acoshdef->deriv,1);
257: subp(CO,xx,(P)ONE,(P *)&args[0]);
258: _mkpfins(powdef,args,&v); MKV(v,t);
259: acoshdef->deriv[0] = (Obj)t;
260:
261: /* d/dx(atanh(x)) = 1/(1-x^2) */
262: OALLOC(atanhdef->deriv,1);
263: subp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atanhdef->deriv[0]);
264: }
265:
266: void mkpow(vl,a,e,r)
267: VL vl;
268: Obj a;
269: Obj e;
270: Obj *r;
271: {
272: PFINS ins;
273: PFAD ad;
274:
275: ins = (PFINS)CALLOC(1,sizeof(PF)+2*sizeof(struct oPFAD));
276: ins->pf = powdef; ad = ins->ad;
277: ad[0].d = 0; ad[0].arg = a; ad[1].d = 0; ad[1].arg = e;
278: simplify_ins(ins,r);
279: }
280:
281: void simplify_pow(ins,rp)
282: PFINS ins;
283: Obj *rp;
284: {
285: PF pf;
286: PFAD ad;
287: Obj a0,a1;
288: V v;
289: P t;
290:
291: pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg;
292: if ( !a1 )
293: *rp = (Obj)ONE;
1.8 noro 294: else if ( !a0 ) {
295: if ( RATN(a1) && SGN((Q)a1)>0 )
296: *rp = 0;
297: else if ( RATN(a1) && SGN((Q)a1) < 0 )
298: error("simplify_pow : division by 0");
299: else {
300: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
301: }
302: } else if ( NUM(a1) && INT(a1) )
1.1 noro 303: arf_pwr(CO,a0,a1,rp);
304: else {
305: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
306: }
307: }
308:
309: #define ISPFINS(p)\
1.10 ! noro 310: ((p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr==V_PF)&&\
! 311: UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p))))
1.1 noro 312:
313: void Pfunctor(arg,rp)
314: NODE arg;
315: P *rp;
316: {
317: P p;
318: FUNC t;
319: PF pf;
320: PFINS ins;
321:
322: p = (P)ARG0(arg);
323: if ( !ISPFINS(p) )
324: *rp = 0;
325: else {
326: ins = (PFINS)VR(p)->priv; pf = ins->pf;
327: t = (FUNC)MALLOC(sizeof(struct oFUNC));
1.7 noro 328: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
1.1 noro 329: t->f.puref = pf;
330: makesrvar(t,rp);
331: }
332: }
333:
334: void Pargs(arg,rp)
335: NODE arg;
336: LIST *rp;
337: {
338: P p;
339: PF pf;
340: PFAD ad;
341: PFINS ins;
342: NODE n,n0;
343: int i;
344:
345: p = (P)ARG0(arg);
346: if ( !ISPFINS(p) )
347: *rp = 0;
348: else {
349: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
350: for ( i = 0, n0 = 0; i < pf->argc; i++ ) {
351: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
352: }
353: if ( n0 )
354: NEXT(n) = 0;
355: MKLIST(*rp,n0);
356: }
357: }
358:
359: void Pfunargs(arg,rp)
360: NODE arg;
361: LIST *rp;
362: {
363: P p;
364: P f;
365: FUNC t;
366: PF pf;
367: PFINS ins;
368: PFAD ad;
369: NODE n,n0;
370: int i;
371:
372: p = (P)ARG0(arg);
373: if ( !ISPFINS(p) )
374: *rp = 0;
375: else {
376: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
377: t = (FUNC)MALLOC(sizeof(struct oFUNC));
1.7 noro 378: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
1.1 noro 379: t->f.puref = pf;
380: makesrvar(t,&f);
1.5 noro 381: n = n0 = 0; NEXTNODE(n0,n); BDY(n) = (pointer)f;
1.1 noro 382: for ( i = 0; i < pf->argc; i++ ) {
383: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
384: }
385: NEXT(n) = 0;
1.10 ! noro 386: MKLIST(*rp,n0);
! 387: }
! 388: }
! 389:
! 390: void Pfunargs_ext(arg,rp)
! 391: NODE arg;
! 392: LIST *rp;
! 393: {
! 394: P p;
! 395: P f;
! 396: FUNC t;
! 397: PF pf;
! 398: PFINS ins;
! 399: PFAD ad;
! 400: NODE n,n0,d,d0,a,a0;
! 401: LIST alist,dlist;
! 402: Q q;
! 403: int i;
! 404:
! 405: p = (P)ARG0(arg);
! 406: if ( !ISPFINS(p) )
! 407: *rp = 0;
! 408: else {
! 409: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
! 410: t = (FUNC)MALLOC(sizeof(struct oFUNC));
! 411: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
! 412: t->f.puref = pf;
! 413: makesrvar(t,&f);
! 414:
! 415: d0 = a0 = 0;
! 416: for ( i = 0; i < pf->argc; i++ ) {
! 417: NEXTNODE(d0,d); STOQ(ad[i].d,q); BDY(d) = (pointer)q;
! 418: NEXTNODE(a0,a); BDY(a) = (pointer)ad[i].arg;
! 419: }
! 420: NEXT(d) = 0; NEXT(a) = 0; MKLIST(alist,a0); MKLIST(dlist,d0);
! 421:
! 422: n0 = mknode(3,f,dlist,alist);
1.1 noro 423: MKLIST(*rp,n0);
424: }
425: }
426:
427: void Pvtype(arg,rp)
428: NODE arg;
429: Q *rp;
430: {
431: P p;
432:
433: p = (P)ARG0(arg);
434: if ( !p || ID(p) != O_P )
435: *rp = 0;
436: else
437: STOQ((int)VR(p)->attr,*rp);
438: }
439:
1.9 noro 440: extern NODE user_int_handler,user_quit_handler;
1.1 noro 441:
442: void Pregister_handler(arg,rp)
443: NODE arg;
444: Q *rp;
445: {
446: P p;
447: V v;
1.9 noro 448: NODE n;
1.1 noro 449: FUNC func;
450:
451: p = (P)ARG0(arg);
1.9 noro 452: if ( !p ) {
453: user_int_handler = 0;
454: *rp = 0;
455: return;
456: } else if ( OID(p) != 2 )
1.1 noro 457: error("register_hanlder : invalid argument");
458: v = VR(p);
459: if ( (int)v->attr != V_SR )
460: error("register_hanlder : no such function");
461: else {
462: func = (FUNC)v->priv;
463: if ( func->argc )
464: error("register_hanlder : the function must be with no argument");
465: else {
1.9 noro 466: MKNODE(n,(pointer)func,user_int_handler);
467: user_int_handler = n;
1.1 noro 468: *rp = ONE;
1.9 noro 469: }
470: }
471: }
472:
473: void Padd_handler(arg,rp)
474: NODE arg;
475: Q *rp;
476: {
477: P p;
478: V v;
479: NODE n;
480: FUNC func;
481: char *name;
482: NODE *hlistp;
483:
484: asir_assert(ARG0(arg),O_STR,"add_handler");
485: name = BDY((STRING)ARG0(arg));
486: p = (P)ARG1(arg);
487: if ( !strcmp(name,"intr") )
488: hlistp = &user_int_handler;
489: else if ( !strcmp(name,"quit") )
490: hlistp = &user_quit_handler;
491: else
492: error("add_handler : invalid keyword (must be \"intr\" or \"quit\")");
493: if ( !p ) {
494: *hlistp = 0; *rp = 0;
495: return;
496: }
497: if ( OID(p) == 2 ) {
498: v = VR(p);
499: if ( (int)v->attr != V_SR )
500: error("add_hanlder : no such function");
501: func = (FUNC)v->priv;
502: } else if ( OID(p) == O_STR ) {
503: gen_searchf_searchonly(BDY((STRING)p),&func);
504: if ( !func )
505: error("add_hanlder : no such function");
1.1 noro 506: }
1.9 noro 507: if ( func->argc )
508: error("register_hanlder : the function must be with no argument");
509: else {
510: MKNODE(n,(pointer)func,*hlistp);
511: *hlistp = n;
512: *rp = ONE;
513: }
514: }
515:
516: void Plist_handler(arg,rp)
517: NODE arg;
518: LIST *rp;
519: {
520: NODE r0,r,t;
521: char *name;
522: NODE hlist;
523: STRING fname;
524:
525: asir_assert(ARG0(arg),O_STR,"list_handler");
526: name = BDY((STRING)ARG0(arg));
527: if ( !strcmp(name,"intr") )
528: hlist = user_int_handler;
529: else if ( !strcmp(name,"quit") )
530: hlist = user_quit_handler;
531: else
532: error("list_handler : invalid keyword (must be \"intr\" or \"quit\")");
533: for ( r0 = 0, t = hlist; t; t = NEXT(t) ) {
534: NEXTNODE(r0,r);
535: MKSTR(fname,((FUNC)BDY(t))->fullname);
536: BDY(r) = (pointer)fname;
537: }
538: if ( r0 ) NEXT(r) = 0;
539: MKLIST(*rp,r0);
540: }
541:
542: void Pclear_handler(arg,rp)
543: NODE arg;
544: Q *rp;
545: {
546: NODE r0,r,t;
547: char *name;
548: NODE hlist;
549: STRING fname;
550:
551: asir_assert(ARG0(arg),O_STR,"clear_handler");
552: name = BDY((STRING)ARG0(arg));
553: if ( !strcmp(name,"intr") )
554: user_int_handler = 0;
555: else if ( !strcmp(name,"quit") )
556: user_quit_handler = 0;
557: else
558: error("clear_handler : invalid keyword (must be \"intr\" or \"quit\")");
559: *rp = 0;
1.1 noro 560: }
561:
1.7 noro 562: void Pcall(NODE arg,Obj *rp)
1.1 noro 563: {
564: P p;
565: V v;
566:
567: p = (P)ARG0(arg);
568: if ( !p || OID(p) != 2 )
569: error("call : invalid argument");
570: v = VR(p);
571: if ( (int)v->attr != V_SR )
572: error("call : no such function");
573:
574: else
575: *rp = (Obj)bevalf((FUNC)v->priv,BDY((LIST)ARG1(arg)));
1.7 noro 576: }
577:
578: /* at=position of arg to be used for iteration */
579:
580: void Pmapat(NODE arg,Obj *rp)
581: {
582: LIST args;
583: NODE node,rest,t0,t,n,r,r0;
584: P fpoly;
585: V fvar;
586: FUNC f;
587: VECT v,rv;
588: MAT m,rm;
589: LIST rl;
590: int len,row,col,i,j,pos;
591: Obj iter;
592: pointer val;
593:
594: if ( argc(arg) < 3 )
595: error("mapat : too few arguments");
596:
597: fpoly = (P)ARG0(arg);
598: if ( !fpoly || OID(fpoly) != O_P )
599: error("mapat : invalid function specification");
600: fvar = VR(fpoly);
601: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
602: error("mapat : invalid function specification");
603: if ( !INT(ARG1(arg)) )
604: error("mapat : invalid position");
605: pos = QTOS((Q)ARG1(arg));
606: node = NEXT(NEXT(arg));
607: len = length(node);
608: if ( pos >= len )
609: error("evalmapatf : invalid position");
610: r0 = 0;
611: for ( i = 0, t = node; i < pos; i++, t = NEXT(t) ) {
612: NEXTNODE(r0,r);
613: BDY(r) = BDY(t);
614: }
615: NEXTNODE(r0,r);
616: iter = BDY(t); rest = NEXT(t);
617: if ( !iter ) {
618: *rp = bevalf(f,node);
619: return;
620: }
621: switch ( OID(iter) ) {
622: case O_VECT:
623: v = (VECT)iter; len = v->len; MKVECT(rv,len);
624: for ( i = 0; i < len; i++ ) {
625: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
626: BDY(rv)[i] = bevalf(f,r0);
627: }
628: *rp = (Obj)rv;
629: break;
630: case O_MAT:
631: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
632: for ( i = 0; i < row; i++ )
633: for ( j = 0; j < col; j++ ) {
634: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
635: BDY(rm)[i][j] = bevalf(f,r0);
636: }
637: *rp = (Obj)rm;
638: break;
639: case O_LIST:
640: n = BDY((LIST)iter);
641: for ( t0 = t = 0; n; n = NEXT(n) ) {
642: BDY(r) = BDY(n); NEXT(r) = rest;
643: NEXTNODE(t0,t); BDY(t) = bevalf(f,r0);
644: }
645: if ( t0 )
646: NEXT(t) = 0;
647: MKLIST(rl,t0);
648: *rp = (Obj)rl;
649: break;
650: default:
651: *rp = bevalf(f,node);
652: break;
653: }
1.1 noro 654: }
655:
656: void Pdeval(arg,rp)
657: NODE arg;
658: Obj *rp;
659: {
660: asir_assert(ARG0(arg),O_R,"deval");
661: devalr(CO,(Obj)ARG0(arg),rp);
662: }
663:
1.4 noro 664: void Peval_quote(arg,rp)
665: NODE arg;
666: Obj *rp;
667: {
668: asir_assert(ARG0(arg),O_QUOTE,"eval_quote");
669: *rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));
670: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to pf.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin