Annotation of OpenXM_contrib2/asir2000/builtin/pf.c, Revision 1.18
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.18 ! ohara 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.17 2011/09/14 06:41:20 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 *);
1.18 ! ohara 65: FNODE partial_eval(FNODE f);
1.1 noro 66:
1.10 noro 67: void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(),Pfunargs_ext();
1.1 noro 68: void Pregister_handler();
1.4 noro 69: void Peval_quote();
1.13 ohara 70: void Pmapat(), Pmap();
1.9 noro 71: void Padd_handler();
72: void Plist_handler();
73: void Pclear_handler();
1.1 noro 74:
75: struct ftab puref_tab[] = {
1.7 noro 76: {"mapat",Pmapat,-99999999},
1.13 ohara 77: {"map",Pmap,-99999999},
1.1 noro 78: {"functor",Pfunctor,1},
79: {"args",Pargs,1},
80: {"funargs",Pfunargs,1},
1.10 noro 81: {"funargs_ext",Pfunargs_ext,1},
1.1 noro 82: {"register_handler",Pregister_handler,1},
1.9 noro 83: {"add_handler",Padd_handler,2},
84: {"list_handler",Plist_handler,1},
85: {"clear_handler",Pclear_handler,1},
1.1 noro 86: {"call",Pcall,2},
87: {"vtype",Pvtype,1},
88: {"deval",Pdeval,1},
1.11 noro 89: {"eval_quote",Peval_quote,-2},
1.1 noro 90: {0,0,0},
91: };
92:
1.6 ohara 93: #if defined(PARI)
1.1 noro 94: int p_pi(),p_e();
95: int p_log(),p_exp(),p_pow();
96: int p_sin(),p_cos(),p_tan(),p_asin(),p_acos(),p_atan();
97: int p_sinh(),p_cosh(),p_tanh(),p_asinh(),p_acosh(),p_atanh();
98: #else
99: int p_pi,p_e;
100: int p_log,p_exp,p_pow;
101: int p_sin,p_cos,p_tan,p_asin,p_acos,p_atan;
102: int p_sinh,p_cosh,p_tanh,p_asinh,p_acosh,p_atanh;
103: #endif
104:
105: static V *uarg,*darg;
106: static P x,y;
107: static PF pidef,edef;
108: static PF logdef,expdef,powdef;
109: static PF sindef,cosdef,tandef;
110: static PF asindef,acosdef,atandef;
111: static PF sinhdef,coshdef,tanhdef;
112: static PF asinhdef,acoshdef,atanhdef;
113:
114: #define OALLOC(p,n) ((p)=(Obj *)CALLOC((n),sizeof(Obj)))
115:
116: double const_pi() { return 3.14159265358979323846264338327950288; }
117: double const_e() { return 2.718281828459045235360287471352662497; }
118:
119: void pf_init() {
120: uarg = (V *)CALLOC(1,sizeof(V));
121: uarg[0] = &oVAR[26]; MKV(uarg[0],x);
122:
123: darg = (V *)CALLOC(2,sizeof(V));
124: darg[0] = &oVAR[26];
125: darg[1] = &oVAR[27]; MKV(darg[1],y);
126:
127: mkpf("@pi",0,0,0,(int (*)())p_pi,const_pi,0,&pidef);
128: mkpf("@e",0,0,0,(int (*)())p_e,const_e,0,&edef);
129:
130: mkpf("log",0,1,uarg,(int (*)())p_log,log,0,&logdef);
131: mkpf("exp",0,1,uarg,(int (*)())p_exp,exp,0,&expdef);
132: mkpf("pow",0,2,darg,(int (*)())p_pow,pow,(int (*)())simplify_pow,&powdef);
133:
134: mkpf("sin",0,1,uarg,(int (*)())p_sin,sin,0,&sindef);
135: mkpf("cos",0,1,uarg,(int (*)())p_cos,cos,0,&cosdef);
136: mkpf("tan",0,1,uarg,(int (*)())p_tan,tan,0,&tandef);
137: mkpf("asin",0,1,uarg,(int (*)())p_asin,asin,0,&asindef);
138: mkpf("acos",0,1,uarg,(int (*)())p_acos,acos,0,&acosdef);
139: mkpf("atan",0,1,uarg,(int (*)())p_atan,atan,0,&atandef);
140:
141: mkpf("sinh",0,1,uarg,(int (*)())p_sinh,sinh,0,&sinhdef);
142: mkpf("cosh",0,1,uarg,(int (*)())p_cosh,cosh,0,&coshdef);
143: mkpf("tanh",0,1,uarg,(int (*)())p_tanh,tanh,0,&tanhdef);
144: #if !defined(VISUAL)
145: mkpf("asinh",0,1,uarg,(int (*)())p_asinh,asinh,0,&asinhdef);
146: mkpf("acosh",0,1,uarg,(int (*)())p_acosh,acosh,0,&acoshdef);
147: mkpf("atanh",0,1,uarg,(int (*)())p_atanh,atanh,0,&atanhdef);
148: #endif
149: make_exp();
150: make_tri();
151: make_itri();
152: make_hyp();
153: #if !defined(VISUAL)
154: make_ihyp();
155: #endif
156: }
157:
158: void make_exp() {
159: V v;
160: P u,vexp,vlog,vpow;
161: Obj *args;
162:
163: mkpfins(expdef,uarg,&v); MKV(v,vexp);
164: mkpfins(powdef,darg,&v); MKV(v,vpow);
165: mkpfins(logdef,uarg,&v); MKV(v,vlog);
166:
167: /* d/dx(log(x)) = 1/x */
168: OALLOC(logdef->deriv,1); divr(CO,(Obj)ONE,(Obj)x,&logdef->deriv[0]);
169:
170: /* d/dx(exp(x)) = exp(x) */
171: OALLOC(expdef->deriv,1); expdef->deriv[0] = (Obj)vexp;
172:
173: /* d/dy(x^y) = log(x)*x^y */
174: OALLOC(powdef->deriv,2); mulp(CO,vpow,vlog,(P *)&powdef->deriv[1]);
175:
176: /* d/dx(x^y) = y*x^(y-1) */
177: args = (Obj *)ALLOCA(2*sizeof(Obj));
178: args[0] = (Obj)x; subp(CO,y,(P)ONE,(P *)&args[1]);
179: _mkpfins(powdef,args,&v); MKV(v,u);
180: mulr(CO,(Obj)u,(Obj)y,&powdef->deriv[0]);
181: }
182:
183: void make_tri() {
184: V v;
185: P vcos,vsin,vtan,t;
186:
187: mkpfins(cosdef,uarg,&v); MKV(v,vcos);
188: mkpfins(sindef,uarg,&v); MKV(v,vsin);
189: mkpfins(tandef,uarg,&v); MKV(v,vtan);
190:
191: /* d/dx(sin(x)) = cos(x) */
192: OALLOC(sindef->deriv,1); sindef->deriv[0] = (Obj)vcos;
193:
194: /* d/dx(cos(x)) = -sin(x) */
195: OALLOC(cosdef->deriv,1); chsgnp(vsin,(P *)&cosdef->deriv[0]);
196:
197: /* d/dx(tan(x)) = 1+tan(x)^2 */
198: OALLOC(tandef->deriv,1);
199: mulr(CO,(Obj)vtan,(Obj)vtan,(Obj *)&t); addp(CO,(P)ONE,t,(P *)&tandef->deriv[0]);
200: }
201:
202: void make_itri() {
203: P t,xx;
204: Q mtwo;
205: V v;
206: Obj *args;
207:
208: /* d/dx(asin(x)) = (1-x^2)^(-1/2) */
209: OALLOC(asindef->deriv,1);
210: args = (Obj *)ALLOCA(2*sizeof(Obj));
211: mulp(CO,x,x,&xx); subp(CO,(P)ONE,xx,(P *)&args[0]);
212: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
213: _mkpfins(powdef,args,&v); MKV(v,t);
214: asindef->deriv[0] = (Obj)t;
215:
216: /* d/dx(acos(x)) = -(1-x^2)^(-1/2) */
217: OALLOC(acosdef->deriv,1); chsgnp((P)asindef->deriv[0],(P *)&acosdef->deriv[0]);
218:
219: /* d/dx(atan(x)) = 1/(x^2+1) */
220: OALLOC(atandef->deriv,1);
221: addp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atandef->deriv[0]);
222: }
223:
224: void make_hyp() {
225: V v;
226: P vcosh,vsinh,vtanh,t;
227:
228: mkpfins(coshdef,uarg,&v); MKV(v,vcosh);
229: mkpfins(sinhdef,uarg,&v); MKV(v,vsinh);
230: mkpfins(tanhdef,uarg,&v); MKV(v,vtanh);
231:
232: /* d/dx(sinh(x)) = cosh(x) */
233: OALLOC(sinhdef->deriv,1); sinhdef->deriv[0] = (Obj)vcosh;
234:
235: /* d/dx(cosh(x)) = sinh(x) */
236: OALLOC(coshdef->deriv,1); coshdef->deriv[0] = (Obj)vsinh;
237:
238: /* d/dx(tanh(x)) = 1-tanh(x)^2 */
239: OALLOC(tanhdef->deriv,1);
240: mulr(CO,(Obj)vtanh,(Obj)vtanh,(Obj *)&t); subp(CO,(P)ONE,t,(P *)&tanhdef->deriv[0]);
241: }
242:
243: void make_ihyp() {
244: P t,xx;
245: Q mtwo;
246: V v;
247: Obj *args;
248:
249: /* d/dx(asinh(x)) = (1+x^2)^(-1/2) */
250: OALLOC(asinhdef->deriv,1);
251: args = (Obj *)ALLOCA(2*sizeof(Obj));
252: mulp(CO,x,x,&xx); addp(CO,(P)ONE,xx,(P *)&args[0]);
253: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
254: _mkpfins(powdef,args,&v); MKV(v,t);
255: asinhdef->deriv[0] = (Obj)t;
256:
257: /* d/dx(acosh(x)) = (x^2-1)^(-1/2) */
258: OALLOC(acoshdef->deriv,1);
259: subp(CO,xx,(P)ONE,(P *)&args[0]);
260: _mkpfins(powdef,args,&v); MKV(v,t);
261: acoshdef->deriv[0] = (Obj)t;
262:
263: /* d/dx(atanh(x)) = 1/(1-x^2) */
264: OALLOC(atanhdef->deriv,1);
265: subp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atanhdef->deriv[0]);
266: }
267:
268: void mkpow(vl,a,e,r)
269: VL vl;
270: Obj a;
271: Obj e;
272: Obj *r;
273: {
274: PFINS ins;
275: PFAD ad;
276:
277: ins = (PFINS)CALLOC(1,sizeof(PF)+2*sizeof(struct oPFAD));
278: ins->pf = powdef; ad = ins->ad;
279: ad[0].d = 0; ad[0].arg = a; ad[1].d = 0; ad[1].arg = e;
280: simplify_ins(ins,r);
281: }
282:
283: void simplify_pow(ins,rp)
284: PFINS ins;
285: Obj *rp;
286: {
287: PF pf;
288: PFAD ad;
289: Obj a0,a1;
290: V v;
291: P t;
292:
293: pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg;
294: if ( !a1 )
295: *rp = (Obj)ONE;
1.8 noro 296: else if ( !a0 ) {
297: if ( RATN(a1) && SGN((Q)a1)>0 )
298: *rp = 0;
299: else if ( RATN(a1) && SGN((Q)a1) < 0 )
300: error("simplify_pow : division by 0");
301: else {
302: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
303: }
304: } else if ( NUM(a1) && INT(a1) )
1.1 noro 305: arf_pwr(CO,a0,a1,rp);
306: else {
307: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
308: }
309: }
310:
311: #define ISPFINS(p)\
1.10 noro 312: ((p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr==V_PF)&&\
313: UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p))))
1.1 noro 314:
315: void Pfunctor(arg,rp)
316: NODE arg;
317: P *rp;
318: {
319: P p;
320: FUNC t;
321: PF pf;
322: PFINS ins;
323:
324: p = (P)ARG0(arg);
325: if ( !ISPFINS(p) )
326: *rp = 0;
327: else {
328: ins = (PFINS)VR(p)->priv; pf = ins->pf;
329: t = (FUNC)MALLOC(sizeof(struct oFUNC));
1.7 noro 330: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
1.1 noro 331: t->f.puref = pf;
332: makesrvar(t,rp);
333: }
334: }
335:
336: void Pargs(arg,rp)
337: NODE arg;
338: LIST *rp;
339: {
340: P p;
341: PF pf;
342: PFAD ad;
343: PFINS ins;
344: NODE n,n0;
345: int i;
346:
347: p = (P)ARG0(arg);
348: if ( !ISPFINS(p) )
349: *rp = 0;
350: else {
351: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
352: for ( i = 0, n0 = 0; i < pf->argc; i++ ) {
353: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
354: }
355: if ( n0 )
356: NEXT(n) = 0;
357: MKLIST(*rp,n0);
358: }
359: }
360:
361: void Pfunargs(arg,rp)
362: NODE arg;
363: LIST *rp;
364: {
365: P p;
366: P f;
367: FUNC t;
368: PF pf;
369: PFINS ins;
370: PFAD ad;
371: NODE n,n0;
372: int i;
373:
374: p = (P)ARG0(arg);
375: if ( !ISPFINS(p) )
376: *rp = 0;
377: else {
378: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
379: t = (FUNC)MALLOC(sizeof(struct oFUNC));
1.7 noro 380: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
1.1 noro 381: t->f.puref = pf;
382: makesrvar(t,&f);
1.5 noro 383: n = n0 = 0; NEXTNODE(n0,n); BDY(n) = (pointer)f;
1.1 noro 384: for ( i = 0; i < pf->argc; i++ ) {
385: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
386: }
387: NEXT(n) = 0;
1.10 noro 388: MKLIST(*rp,n0);
389: }
390: }
391:
392: void Pfunargs_ext(arg,rp)
393: NODE arg;
394: LIST *rp;
395: {
396: P p;
397: P f;
398: FUNC t;
399: PF pf;
400: PFINS ins;
401: PFAD ad;
402: NODE n,n0,d,d0,a,a0;
403: LIST alist,dlist;
404: Q q;
405: int i;
406:
407: p = (P)ARG0(arg);
408: if ( !ISPFINS(p) )
409: *rp = 0;
410: else {
411: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
412: t = (FUNC)MALLOC(sizeof(struct oFUNC));
413: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
414: t->f.puref = pf;
415: makesrvar(t,&f);
416:
417: d0 = a0 = 0;
418: for ( i = 0; i < pf->argc; i++ ) {
419: NEXTNODE(d0,d); STOQ(ad[i].d,q); BDY(d) = (pointer)q;
420: NEXTNODE(a0,a); BDY(a) = (pointer)ad[i].arg;
421: }
422: NEXT(d) = 0; NEXT(a) = 0; MKLIST(alist,a0); MKLIST(dlist,d0);
423:
424: n0 = mknode(3,f,dlist,alist);
1.1 noro 425: MKLIST(*rp,n0);
426: }
427: }
428:
429: void Pvtype(arg,rp)
430: NODE arg;
431: Q *rp;
432: {
433: P p;
434:
435: p = (P)ARG0(arg);
436: if ( !p || ID(p) != O_P )
437: *rp = 0;
438: else
439: STOQ((int)VR(p)->attr,*rp);
440: }
441:
1.9 noro 442: extern NODE user_int_handler,user_quit_handler;
1.1 noro 443:
444: void Pregister_handler(arg,rp)
445: NODE arg;
446: Q *rp;
447: {
448: P p;
449: V v;
1.9 noro 450: NODE n;
1.1 noro 451: FUNC func;
452:
453: p = (P)ARG0(arg);
1.9 noro 454: if ( !p ) {
455: user_int_handler = 0;
456: *rp = 0;
457: return;
458: } else if ( OID(p) != 2 )
1.1 noro 459: error("register_hanlder : invalid argument");
460: v = VR(p);
461: if ( (int)v->attr != V_SR )
462: error("register_hanlder : no such function");
463: else {
464: func = (FUNC)v->priv;
465: if ( func->argc )
466: error("register_hanlder : the function must be with no argument");
467: else {
1.9 noro 468: MKNODE(n,(pointer)func,user_int_handler);
469: user_int_handler = n;
1.1 noro 470: *rp = ONE;
1.9 noro 471: }
472: }
473: }
474:
475: void Padd_handler(arg,rp)
476: NODE arg;
477: Q *rp;
478: {
479: P p;
480: V v;
481: NODE n;
482: FUNC func;
483: char *name;
484: NODE *hlistp;
485:
486: asir_assert(ARG0(arg),O_STR,"add_handler");
487: name = BDY((STRING)ARG0(arg));
488: p = (P)ARG1(arg);
489: if ( !strcmp(name,"intr") )
490: hlistp = &user_int_handler;
491: else if ( !strcmp(name,"quit") )
492: hlistp = &user_quit_handler;
493: else
494: error("add_handler : invalid keyword (must be \"intr\" or \"quit\")");
495: if ( !p ) {
496: *hlistp = 0; *rp = 0;
497: return;
498: }
499: if ( OID(p) == 2 ) {
500: v = VR(p);
501: if ( (int)v->attr != V_SR )
502: error("add_hanlder : no such function");
503: func = (FUNC)v->priv;
504: } else if ( OID(p) == O_STR ) {
505: gen_searchf_searchonly(BDY((STRING)p),&func);
506: if ( !func )
507: error("add_hanlder : no such function");
1.1 noro 508: }
1.9 noro 509: if ( func->argc )
510: error("register_hanlder : the function must be with no argument");
511: else {
512: MKNODE(n,(pointer)func,*hlistp);
513: *hlistp = n;
514: *rp = ONE;
515: }
516: }
517:
518: void Plist_handler(arg,rp)
519: NODE arg;
520: LIST *rp;
521: {
522: NODE r0,r,t;
523: char *name;
524: NODE hlist;
525: STRING fname;
526:
527: asir_assert(ARG0(arg),O_STR,"list_handler");
528: name = BDY((STRING)ARG0(arg));
529: if ( !strcmp(name,"intr") )
530: hlist = user_int_handler;
531: else if ( !strcmp(name,"quit") )
532: hlist = user_quit_handler;
533: else
534: error("list_handler : invalid keyword (must be \"intr\" or \"quit\")");
535: for ( r0 = 0, t = hlist; t; t = NEXT(t) ) {
536: NEXTNODE(r0,r);
537: MKSTR(fname,((FUNC)BDY(t))->fullname);
538: BDY(r) = (pointer)fname;
539: }
540: if ( r0 ) NEXT(r) = 0;
541: MKLIST(*rp,r0);
542: }
543:
544: void Pclear_handler(arg,rp)
545: NODE arg;
546: Q *rp;
547: {
548: NODE r0,r,t;
549: char *name;
550: NODE hlist;
551: STRING fname;
552:
553: asir_assert(ARG0(arg),O_STR,"clear_handler");
554: name = BDY((STRING)ARG0(arg));
555: if ( !strcmp(name,"intr") )
556: user_int_handler = 0;
557: else if ( !strcmp(name,"quit") )
558: user_quit_handler = 0;
559: else
560: error("clear_handler : invalid keyword (must be \"intr\" or \"quit\")");
561: *rp = 0;
1.1 noro 562: }
563:
1.7 noro 564: void Pcall(NODE arg,Obj *rp)
1.1 noro 565: {
566: P p;
567: V v;
1.14 ohara 568: NODE n,n1;
569: LIST list;
570: VECT vect;
571: pointer *a;
572: int len,i;
1.1 noro 573:
574: p = (P)ARG0(arg);
575: if ( !p || OID(p) != 2 )
576: error("call : invalid argument");
577: v = VR(p);
578: if ( (int)v->attr != V_SR )
579: error("call : no such function");
1.14 ohara 580: else {
581: list = (LIST) ARG1(arg);
582: if ( list ) {
583: switch (OID(list)) {
584: case O_VECT:
585: vect = (VECT)list; len = vect->len; a = BDY(vect);
586: for ( i = len - 1, n = 0; i >= 0; i-- ) {
587: MKNODE(n1,a[i],n); n = n1;
588: }
589: MKLIST(list,n);
590: /* falling next case */
591: case O_LIST:
1.15 ohara 592: *rp = (Obj)bevalf_with_opts((FUNC)v->priv,BDY(list),current_option);
1.14 ohara 593: return;
594: default:
595: break;
596: }
597: }
598: error("call : invalid argument");
599: }
1.7 noro 600: }
601:
602: /* at=position of arg to be used for iteration */
603:
604: void Pmapat(NODE arg,Obj *rp)
605: {
606: LIST args;
607: NODE node,rest,t0,t,n,r,r0;
608: P fpoly;
609: V fvar;
610: FUNC f;
611: VECT v,rv;
612: MAT m,rm;
613: LIST rl;
614: int len,row,col,i,j,pos;
615: Obj iter;
616: pointer val;
1.16 ohara 617: NODE option;
618:
619: option = current_option;
1.7 noro 620:
621: if ( argc(arg) < 3 )
622: error("mapat : too few arguments");
623:
624: fpoly = (P)ARG0(arg);
625: if ( !fpoly || OID(fpoly) != O_P )
626: error("mapat : invalid function specification");
627: fvar = VR(fpoly);
628: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
629: error("mapat : invalid function specification");
630: if ( !INT(ARG1(arg)) )
631: error("mapat : invalid position");
632: pos = QTOS((Q)ARG1(arg));
633: node = NEXT(NEXT(arg));
634: len = length(node);
635: if ( pos >= len )
636: error("evalmapatf : invalid position");
637: r0 = 0;
638: for ( i = 0, t = node; i < pos; i++, t = NEXT(t) ) {
639: NEXTNODE(r0,r);
640: BDY(r) = BDY(t);
641: }
642: NEXTNODE(r0,r);
643: iter = BDY(t); rest = NEXT(t);
644: if ( !iter ) {
1.16 ohara 645: *rp = bevalf_with_opts(f,node,option);
1.7 noro 646: return;
647: }
648: switch ( OID(iter) ) {
649: case O_VECT:
650: v = (VECT)iter; len = v->len; MKVECT(rv,len);
651: for ( i = 0; i < len; i++ ) {
652: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
1.16 ohara 653: BDY(rv)[i] = bevalf_with_opts(f,r0,option);
1.7 noro 654: }
655: *rp = (Obj)rv;
656: break;
657: case O_MAT:
658: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
659: for ( i = 0; i < row; i++ )
660: for ( j = 0; j < col; j++ ) {
661: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
1.16 ohara 662: BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);
1.7 noro 663: }
664: *rp = (Obj)rm;
665: break;
666: case O_LIST:
667: n = BDY((LIST)iter);
668: for ( t0 = t = 0; n; n = NEXT(n) ) {
669: BDY(r) = BDY(n); NEXT(r) = rest;
1.16 ohara 670: NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);
1.7 noro 671: }
672: if ( t0 )
673: NEXT(t) = 0;
674: MKLIST(rl,t0);
675: *rp = (Obj)rl;
676: break;
677: default:
1.16 ohara 678: *rp = bevalf_with_opts(f,node,option);
1.7 noro 679: break;
680: }
1.1 noro 681: }
682:
1.13 ohara 683: /* An implementation of 'map' as builtin function. */
684: void Pmap(NODE arg,Obj *rp)
685: {
686: LIST args;
687: NODE node,rest,t0,t,n,r,r0;
688: P fpoly;
689: V fvar;
690: FUNC f;
691: VECT v,rv;
692: MAT m,rm;
693: LIST rl;
694: int len,row,col,i,j;
695: Obj iter;
696: pointer val;
1.16 ohara 697: NODE option;
698:
699: option = current_option;
1.13 ohara 700:
701: if ( argc(arg) < 2 )
702: error("mapat : too few arguments");
703:
704: fpoly = (P)ARG0(arg);
705: if ( !fpoly || OID(fpoly) != O_P )
706: error("map : invalid function specification");
707: fvar = VR(fpoly);
708: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
709: error("map : invalid function specification");
710:
711: node = NEXT(arg);
712: len = length(node);
713: if ( 0 >= len )
714: error("evalmapf : invalid position");
715: r0 = 0;
716: NEXTNODE(r0,r);
1.17 noro 717: iter = BDY(node); rest = NEXT(node);
1.13 ohara 718: if ( !iter ) {
1.16 ohara 719: *rp = bevalf_with_opts(f,node,option);
1.13 ohara 720: return;
721: }
722: switch ( OID(iter) ) {
723: case O_VECT:
724: v = (VECT)iter; len = v->len; MKVECT(rv,len);
725: for ( i = 0; i < len; i++ ) {
726: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
1.16 ohara 727: BDY(rv)[i] = bevalf_with_opts(f,r0,option);
1.13 ohara 728: }
729: *rp = (Obj)rv;
730: break;
731: case O_MAT:
732: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
733: for ( i = 0; i < row; i++ )
734: for ( j = 0; j < col; j++ ) {
735: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
1.16 ohara 736: BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);
1.13 ohara 737: }
738: *rp = (Obj)rm;
739: break;
740: case O_LIST:
741: n = BDY((LIST)iter);
742: for ( t0 = t = 0; n; n = NEXT(n) ) {
743: BDY(r) = BDY(n); NEXT(r) = rest;
1.16 ohara 744: NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);
1.13 ohara 745: }
746: if ( t0 )
747: NEXT(t) = 0;
748: MKLIST(rl,t0);
749: *rp = (Obj)rl;
750: break;
751: default:
1.16 ohara 752: *rp = bevalf_with_opts(f,node,option);
1.13 ohara 753: break;
754: }
755: }
756:
1.1 noro 757: void Pdeval(arg,rp)
758: NODE arg;
759: Obj *rp;
760: {
761: asir_assert(ARG0(arg),O_R,"deval");
762: devalr(CO,(Obj)ARG0(arg),rp);
763: }
764:
1.4 noro 765: void Peval_quote(arg,rp)
766: NODE arg;
767: Obj *rp;
768: {
1.11 noro 769: FNODE a;
770: QUOTE q;
1.12 noro 771: Obj f;
1.11 noro 772:
1.12 noro 773: f = (Obj)ARG0(arg);
774: if ( !f || OID(f) != O_QUOTE ) {
775: *rp = f;
776: return;
777: }
1.11 noro 778: if ( argc(arg) == 2 && ARG1(arg) ) {
779: a = partial_eval((FNODE)BDY((QUOTE)ARG0(arg)));
780: MKQUOTE(q,a);
781: *rp = (Obj)q;
782: } else
783: *rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));
1.4 noro 784: }
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