Annotation of OpenXM_contrib2/asir2000/builtin/pf.c, Revision 1.26
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.26 ! kondoh 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.25 2018/03/29 01:32:50 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:
1.24 noro 57: double const_pi(),const_e(), double_factorial();
1.1 noro 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.25 noro 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},
1.1 noro 91: };
92:
1.20 noro 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();
1.24 noro 97: int mp_factorial(),mp_abs();
1.1 noro 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;
1.24 noro 107: static PF factorialdef,absdef;
1.1 noro 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:
1.24 noro 114: double double_factorial(double x)
115: {
116: return tgamma(x+1);
117: }
118:
1.19 noro 119: int simplify_elemfunc_ins();
1.24 noro 120: int simplify_factorial_ins();
121: int simplify_abs_ins();
1.19 noro 122:
1.1 noro 123: void pf_init() {
1.25 noro 124: uarg = (V *)CALLOC(1,sizeof(V));
125: uarg[0] = &oVAR[26]; MKV(uarg[0],x);
1.1 noro 126:
1.25 noro 127: darg = (V *)CALLOC(2,sizeof(V));
128: darg[0] = &oVAR[26];
129: darg[1] = &oVAR[27]; MKV(darg[1],y);
130:
1.26 ! 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.25 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);
1.22 fujimoto 178: #if !defined(VISUAL) && !defined(__MINGW32__)
1.25 noro 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);
1.1 noro 182: #endif
1.26 ! kondoh 183: #endif
1.25 noro 184: make_exp();
185: make_tri();
186: make_itri();
187: make_hyp();
1.22 fujimoto 188: #if !defined(VISUAL) && !defined(__MINGW32__)
1.25 noro 189: make_ihyp();
1.1 noro 190: #endif
191: }
192:
193: void make_exp() {
1.25 noro 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]);
1.1 noro 216: }
217:
218: void make_tri() {
1.25 noro 219: V v;
220: P vcos,vsin,vtan,t;
1.1 noro 221:
1.25 noro 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]);
1.1 noro 235: }
236:
237: void make_itri() {
1.25 noro 238: P t,xx;
239: Q 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]);
247: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
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]);
1.1 noro 257: }
258:
259: void make_hyp() {
1.25 noro 260: V v;
261: P vcosh,vsinh,vtanh,t;
1.1 noro 262:
1.25 noro 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]);
1.1 noro 276: }
277:
278: void make_ihyp() {
1.25 noro 279: P t,xx;
280: Q 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]);
288: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
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]);
1.1 noro 301: }
302:
303: void mkpow(vl,a,e,r)
304: VL vl;
305: Obj a;
306: Obj e;
307: Obj *r;
308: {
1.25 noro 309: PFINS ins;
310: PFAD ad;
1.1 noro 311:
1.25 noro 312: ins = (PFINS)CALLOC(1,sizeof(PF)+2*sizeof(struct oPFAD));
313: ins->pf = powdef; ad = ins->ad;
314: ad[0].d = 0; ad[0].arg = a; ad[1].d = 0; ad[1].arg = e;
315: simplify_ins(ins,r);
1.1 noro 316: }
317:
1.23 noro 318: extern int evalef;
319:
1.1 noro 320: void simplify_pow(ins,rp)
321: PFINS ins;
322: Obj *rp;
323: {
1.25 noro 324: PF pf;
325: PFAD ad;
326: Obj a0,a1;
327: V v;
328: P t;
329:
330: if ( evalef ) {
331: simplify_elemfunc_ins(ins,rp);
332: return;
333: }
334: pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg;
335: if ( !a1 )
336: *rp = (Obj)ONE;
337: else if ( !a0 ) {
338: if ( RATN(a1) && SGN((Q)a1)>0 )
339: *rp = 0;
340: else if ( RATN(a1) && SGN((Q)a1) < 0 )
341: error("simplify_pow : division by 0");
342: else {
343: instoobj(ins,rp);
344: }
345: } else if ( NUM(a1) && INT(a1) )
346: arf_pwr(CO,a0,a1,rp);
347: else {
348: instoobj(ins,rp);
349: }
1.1 noro 350: }
351:
352: #define ISPFINS(p)\
1.10 noro 353: ((p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr==V_PF)&&\
354: UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p))))
1.1 noro 355:
356: void Pfunctor(arg,rp)
357: NODE arg;
358: P *rp;
359: {
1.25 noro 360: P p;
361: FUNC t;
362: PF pf;
363: PFINS ins;
364:
365: p = (P)ARG0(arg);
366: if ( !ISPFINS(p) )
367: *rp = 0;
368: else {
369: ins = (PFINS)VR(p)->priv; pf = ins->pf;
370: t = (FUNC)MALLOC(sizeof(struct oFUNC));
371: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
372: t->f.puref = pf;
373: makesrvar(t,rp);
374: }
1.1 noro 375: }
376:
377: void Pargs(arg,rp)
378: NODE arg;
379: LIST *rp;
380: {
1.25 noro 381: P p;
382: PF pf;
383: PFAD ad;
384: PFINS ins;
385: NODE n,n0;
386: int i;
387:
388: p = (P)ARG0(arg);
389: if ( !ISPFINS(p) )
390: *rp = 0;
391: else {
392: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
393: for ( i = 0, n0 = 0; i < pf->argc; i++ ) {
394: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
395: }
396: if ( n0 )
397: NEXT(n) = 0;
398: MKLIST(*rp,n0);
399: }
1.1 noro 400: }
401:
402: void Pfunargs(arg,rp)
403: NODE arg;
404: LIST *rp;
405: {
1.25 noro 406: P p;
407: P f;
408: FUNC t;
409: PF pf;
410: PFINS ins;
411: PFAD ad;
412: NODE n,n0;
413: int i;
414:
415: p = (P)ARG0(arg);
416: if ( !ISPFINS(p) )
417: *rp = 0;
418: else {
419: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
420: t = (FUNC)MALLOC(sizeof(struct oFUNC));
421: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
422: t->f.puref = pf;
423: makesrvar(t,&f);
424: n = n0 = 0; NEXTNODE(n0,n); BDY(n) = (pointer)f;
425: for ( i = 0; i < pf->argc; i++ ) {
426: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
427: }
428: NEXT(n) = 0;
429: MKLIST(*rp,n0);
430: }
1.10 noro 431: }
432:
433: void Pfunargs_ext(arg,rp)
434: NODE arg;
435: LIST *rp;
436: {
1.25 noro 437: P p;
438: P f;
439: FUNC t;
440: PF pf;
441: PFINS ins;
442: PFAD ad;
443: NODE n,n0,d,d0,a,a0;
444: LIST alist,dlist;
445: Q q;
446: int i;
447:
448: p = (P)ARG0(arg);
449: if ( !ISPFINS(p) )
450: *rp = 0;
451: else {
452: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
453: t = (FUNC)MALLOC(sizeof(struct oFUNC));
454: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
455: t->f.puref = pf;
456: makesrvar(t,&f);
457:
458: d0 = a0 = 0;
459: for ( i = 0; i < pf->argc; i++ ) {
460: NEXTNODE(d0,d); STOQ(ad[i].d,q); BDY(d) = (pointer)q;
461: NEXTNODE(a0,a); BDY(a) = (pointer)ad[i].arg;
462: }
463: NEXT(d) = 0; NEXT(a) = 0; MKLIST(alist,a0); MKLIST(dlist,d0);
464:
465: n0 = mknode(3,f,dlist,alist);
466: MKLIST(*rp,n0);
467: }
1.1 noro 468: }
469:
470: void Pvtype(arg,rp)
471: NODE arg;
472: Q *rp;
473: {
1.25 noro 474: P p;
1.1 noro 475:
1.25 noro 476: p = (P)ARG0(arg);
477: if ( !p || ID(p) != O_P )
478: *rp = 0;
479: else
480: STOQ((int)VR(p)->attr,*rp);
1.1 noro 481: }
482:
1.9 noro 483: extern NODE user_int_handler,user_quit_handler;
1.1 noro 484:
485: void Pregister_handler(arg,rp)
486: NODE arg;
487: Q *rp;
488: {
1.25 noro 489: P p;
490: V v;
491: NODE n;
492: FUNC func;
493:
494: p = (P)ARG0(arg);
495: if ( !p ) {
496: user_int_handler = 0;
497: *rp = 0;
498: return;
499: } else if ( OID(p) != 2 )
500: error("register_hanlder : invalid argument");
501: v = VR(p);
502: if ( (int)v->attr != V_SR )
503: error("register_hanlder : no such function");
504: else {
505: func = (FUNC)v->priv;
506: if ( func->argc )
507: error("register_hanlder : the function must be with no argument");
508: else {
509: MKNODE(n,(pointer)func,user_int_handler);
510: user_int_handler = n;
511: *rp = ONE;
512: }
513: }
1.9 noro 514: }
515:
516: void Padd_handler(arg,rp)
517: NODE arg;
518: Q *rp;
519: {
1.25 noro 520: P p;
521: V v;
522: NODE n;
523: FUNC func;
524: char *name;
525: NODE *hlistp;
526:
527: asir_assert(ARG0(arg),O_STR,"add_handler");
528: name = BDY((STRING)ARG0(arg));
529: p = (P)ARG1(arg);
530: if ( !strcmp(name,"intr") )
531: hlistp = &user_int_handler;
532: else if ( !strcmp(name,"quit") )
533: hlistp = &user_quit_handler;
534: else
535: error("add_handler : invalid keyword (must be \"intr\" or \"quit\")");
536: if ( !p ) {
537: *hlistp = 0; *rp = 0;
538: return;
539: }
540: if ( OID(p) == 2 ) {
541: v = VR(p);
542: if ( (int)v->attr != V_SR )
543: error("add_hanlder : no such function");
544: func = (FUNC)v->priv;
545: } else if ( OID(p) == O_STR ) {
546: gen_searchf_searchonly(BDY((STRING)p),&func);
547: if ( !func )
548: error("add_hanlder : no such function");
549: }
550: if ( func->argc )
551: error("register_hanlder : the function must be with no argument");
552: else {
553: MKNODE(n,(pointer)func,*hlistp);
554: *hlistp = n;
555: *rp = ONE;
556: }
1.9 noro 557: }
558:
559: void Plist_handler(arg,rp)
560: NODE arg;
561: LIST *rp;
562: {
1.25 noro 563: NODE r0,r,t;
564: char *name;
565: NODE hlist;
566: STRING fname;
567:
568: asir_assert(ARG0(arg),O_STR,"list_handler");
569: name = BDY((STRING)ARG0(arg));
570: if ( !strcmp(name,"intr") )
571: hlist = user_int_handler;
572: else if ( !strcmp(name,"quit") )
573: hlist = user_quit_handler;
574: else
575: error("list_handler : invalid keyword (must be \"intr\" or \"quit\")");
576: for ( r0 = 0, t = hlist; t; t = NEXT(t) ) {
577: NEXTNODE(r0,r);
578: MKSTR(fname,((FUNC)BDY(t))->fullname);
579: BDY(r) = (pointer)fname;
580: }
581: if ( r0 ) NEXT(r) = 0;
582: MKLIST(*rp,r0);
1.9 noro 583: }
584:
585: void Pclear_handler(arg,rp)
586: NODE arg;
587: Q *rp;
588: {
1.25 noro 589: NODE r0,r,t;
590: char *name;
591: NODE hlist;
592: STRING fname;
593:
594: asir_assert(ARG0(arg),O_STR,"clear_handler");
595: name = BDY((STRING)ARG0(arg));
596: if ( !strcmp(name,"intr") )
597: user_int_handler = 0;
598: else if ( !strcmp(name,"quit") )
599: user_quit_handler = 0;
600: else
601: error("clear_handler : invalid keyword (must be \"intr\" or \"quit\")");
602: *rp = 0;
1.1 noro 603: }
604:
1.7 noro 605: void Pcall(NODE arg,Obj *rp)
1.1 noro 606: {
1.25 noro 607: P p;
608: V v;
1.14 ohara 609: NODE n,n1;
610: LIST list;
611: VECT vect;
612: pointer *a;
613: int len,i;
1.1 noro 614:
1.25 noro 615: p = (P)ARG0(arg);
616: if ( !p || OID(p) != 2 )
617: error("call : invalid argument");
618: v = VR(p);
619: if ( (int)v->attr != V_SR )
620: error("call : no such function");
621: else {
1.14 ohara 622: list = (LIST) ARG1(arg);
623: if ( list ) {
624: switch (OID(list)) {
625: case O_VECT:
626: vect = (VECT)list; len = vect->len; a = BDY(vect);
627: for ( i = len - 1, n = 0; i >= 0; i-- ) {
628: MKNODE(n1,a[i],n); n = n1;
629: }
630: MKLIST(list,n);
631: /* falling next case */
632: case O_LIST:
1.15 ohara 633: *rp = (Obj)bevalf_with_opts((FUNC)v->priv,BDY(list),current_option);
1.14 ohara 634: return;
635: default:
636: break;
637: }
638: }
639: error("call : invalid argument");
1.25 noro 640: }
1.7 noro 641: }
642:
643: /* at=position of arg to be used for iteration */
644:
645: void Pmapat(NODE arg,Obj *rp)
646: {
1.25 noro 647: LIST args;
648: NODE node,rest,t0,t,n,r,r0;
649: P fpoly;
650: V fvar;
651: FUNC f;
652: VECT v,rv;
653: MAT m,rm;
654: LIST rl;
655: int len,row,col,i,j,pos;
656: Obj iter;
657: pointer val;
658: NODE option;
659:
660: option = current_option;
661:
662: if ( argc(arg) < 3 )
663: error("mapat : too few arguments");
664:
665: fpoly = (P)ARG0(arg);
666: if ( !fpoly || OID(fpoly) != O_P )
667: error("mapat : invalid function specification");
668: fvar = VR(fpoly);
669: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
670: error("mapat : invalid function specification");
671: if ( !INT(ARG1(arg)) )
672: error("mapat : invalid position");
673: pos = QTOS((Q)ARG1(arg));
674: node = NEXT(NEXT(arg));
675: len = length(node);
676: if ( pos >= len )
677: error("evalmapatf : invalid position");
678: r0 = 0;
679: for ( i = 0, t = node; i < pos; i++, t = NEXT(t) ) {
680: NEXTNODE(r0,r);
681: BDY(r) = BDY(t);
682: }
683: NEXTNODE(r0,r);
684: iter = BDY(t); rest = NEXT(t);
685: if ( !iter ) {
686: *rp = bevalf_with_opts(f,node,option);
687: return;
688: }
689: switch ( OID(iter) ) {
690: case O_VECT:
691: v = (VECT)iter; len = v->len; MKVECT(rv,len);
692: for ( i = 0; i < len; i++ ) {
693: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
694: BDY(rv)[i] = bevalf_with_opts(f,r0,option);
695: }
696: *rp = (Obj)rv;
697: break;
698: case O_MAT:
699: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
700: for ( i = 0; i < row; i++ )
701: for ( j = 0; j < col; j++ ) {
702: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
703: BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);
704: }
705: *rp = (Obj)rm;
706: break;
707: case O_LIST:
708: n = BDY((LIST)iter);
709: for ( t0 = t = 0; n; n = NEXT(n) ) {
710: BDY(r) = BDY(n); NEXT(r) = rest;
711: NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);
712: }
713: if ( t0 )
714: NEXT(t) = 0;
715: MKLIST(rl,t0);
716: *rp = (Obj)rl;
717: break;
718: default:
719: *rp = bevalf_with_opts(f,node,option);
720: break;
721: }
1.1 noro 722: }
723:
1.13 ohara 724: /* An implementation of 'map' as builtin function. */
725: void Pmap(NODE arg,Obj *rp)
726: {
1.25 noro 727: LIST args;
728: NODE node,rest,t0,t,n,r,r0;
729: P fpoly;
730: V fvar;
731: FUNC f;
732: VECT v,rv;
733: MAT m,rm;
734: LIST rl;
735: int len,row,col,i,j;
736: Obj iter;
737: pointer val;
738: NODE option;
739:
740: option = current_option;
741:
742: if ( argc(arg) < 2 )
743: error("mapat : too few arguments");
744:
745: fpoly = (P)ARG0(arg);
746: if ( !fpoly || OID(fpoly) != O_P )
747: error("map : invalid function specification");
748: fvar = VR(fpoly);
749: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
750: error("map : invalid function specification");
751:
752: node = NEXT(arg);
753: len = length(node);
754: if ( 0 >= len )
755: error("evalmapf : invalid position");
756: r0 = 0;
757: NEXTNODE(r0,r);
758: iter = BDY(node); rest = NEXT(node);
759: if ( !iter ) {
760: *rp = bevalf_with_opts(f,node,option);
761: return;
762: }
763: switch ( OID(iter) ) {
764: case O_VECT:
765: v = (VECT)iter; len = v->len; MKVECT(rv,len);
766: for ( i = 0; i < len; i++ ) {
767: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
768: BDY(rv)[i] = bevalf_with_opts(f,r0,option);
769: }
770: *rp = (Obj)rv;
771: break;
772: case O_MAT:
773: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
774: for ( i = 0; i < row; i++ )
775: for ( j = 0; j < col; j++ ) {
776: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
777: BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);
778: }
779: *rp = (Obj)rm;
780: break;
781: case O_LIST:
782: n = BDY((LIST)iter);
783: for ( t0 = t = 0; n; n = NEXT(n) ) {
784: BDY(r) = BDY(n); NEXT(r) = rest;
785: NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);
786: }
787: if ( t0 )
788: NEXT(t) = 0;
789: MKLIST(rl,t0);
790: *rp = (Obj)rl;
791: break;
792: default:
793: *rp = bevalf_with_opts(f,node,option);
794: break;
795: }
1.13 ohara 796: }
797:
1.1 noro 798: void Pdeval(arg,rp)
799: NODE arg;
800: Obj *rp;
801: {
1.25 noro 802: asir_assert(ARG0(arg),O_R,"deval");
803: devalr(CO,(Obj)ARG0(arg),rp);
1.1 noro 804: }
805:
1.4 noro 806: void Peval_quote(arg,rp)
807: NODE arg;
808: Obj *rp;
809: {
1.25 noro 810: FNODE a;
811: QUOTE q;
812: Obj f;
813:
814: f = (Obj)ARG0(arg);
815: if ( !f || OID(f) != O_QUOTE ) {
816: *rp = f;
817: return;
818: }
819: if ( argc(arg) == 2 && ARG1(arg) ) {
820: a = partial_eval((FNODE)BDY((QUOTE)ARG0(arg)));
821: MKQUOTE(q,a);
822: *rp = (Obj)q;
823: } else
824: *rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));
1.4 noro 825: }
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