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