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