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