Annotation of OpenXM_contrib2/asir2018/builtin/pf.c, Revision 1.1
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: *
! 48: * $OpenXM$
! 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:
! 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);
! 151: #if !defined(VISUAL) && !defined(__MINGW32__)
! 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);
! 155: #endif
! 156: make_exp();
! 157: make_tri();
! 158: make_itri();
! 159: make_hyp();
! 160: #if !defined(VISUAL) && !defined(__MINGW32__)
! 161: make_ihyp();
! 162: #endif
! 163: }
! 164:
! 165: void make_exp() {
! 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]);
! 188: }
! 189:
! 190: void make_tri() {
! 191: V v;
! 192: P vcos,vsin,vtan,t;
! 193:
! 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]);
! 207: }
! 208:
! 209: void make_itri() {
! 210: P t,xx;
! 211: Z 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); divz(ONE,mtwo,(Z *)&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]);
! 229: }
! 230:
! 231: void make_hyp() {
! 232: V v;
! 233: P vcosh,vsinh,vtanh,t;
! 234:
! 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]);
! 248: }
! 249:
! 250: void make_ihyp() {
! 251: P t,xx;
! 252: Z 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); divz(ONE,mtwo,(Z *)&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]);
! 273: }
! 274:
! 275: void mkpow(VL vl,Obj a,Obj e,Obj *r)
! 276: {
! 277: PFINS ins;
! 278: PFAD ad;
! 279:
! 280: ins = (PFINS)CALLOC(1,sizeof(PF)+2*sizeof(struct oPFAD));
! 281: ins->pf = powdef; ad = ins->ad;
! 282: ad[0].d = 0; ad[0].arg = a; ad[1].d = 0; ad[1].arg = e;
! 283: simplify_ins(ins,r);
! 284: }
! 285:
! 286: extern int evalef;
! 287:
! 288: void simplify_pow(PFINS ins,Obj * rp)
! 289: {
! 290: PF pf;
! 291: PFAD ad;
! 292: Obj a0,a1;
! 293: V v;
! 294: P t;
! 295:
! 296: if ( evalef ) {
! 297: simplify_elemfunc_ins(ins,rp);
! 298: return;
! 299: }
! 300: pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg;
! 301: if ( !a1 )
! 302: *rp = (Obj)ONE;
! 303: else if ( !a0 ) {
! 304: if ( RATN(a1) && sgnq((Q)a1)>0 )
! 305: *rp = 0;
! 306: else if ( RATN(a1) && sgnq((Q)a1) < 0 )
! 307: error("simplify_pow : division by 0");
! 308: else {
! 309: instoobj(ins,rp);
! 310: }
! 311: } else if ( NUM(a1) && INT(a1) )
! 312: arf_pwr(CO,a0,a1,rp);
! 313: else {
! 314: instoobj(ins,rp);
! 315: }
! 316: }
! 317:
! 318: #define ISPFINS(p)\
! 319: ((p)&&(ID(p) == O_P)&&((long)VR((P)p)->attr==V_PF)&&\
! 320: UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p))))
! 321:
! 322: void Pfunctor(NODE arg,P *rp)
! 323: {
! 324: P p;
! 325: FUNC t;
! 326: PF pf;
! 327: PFINS ins;
! 328:
! 329: p = (P)ARG0(arg);
! 330: if ( !ISPFINS(p) )
! 331: *rp = 0;
! 332: else {
! 333: ins = (PFINS)VR(p)->priv; pf = ins->pf;
! 334: t = (FUNC)MALLOC(sizeof(struct oFUNC));
! 335: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
! 336: t->f.puref = pf;
! 337: makesrvar(t,rp);
! 338: }
! 339: }
! 340:
! 341: void Pargs(NODE arg,LIST *rp)
! 342: {
! 343: P p;
! 344: PF pf;
! 345: PFAD ad;
! 346: PFINS ins;
! 347: NODE n,n0;
! 348: int i;
! 349:
! 350: p = (P)ARG0(arg);
! 351: if ( !ISPFINS(p) )
! 352: *rp = 0;
! 353: else {
! 354: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
! 355: for ( i = 0, n0 = 0; i < pf->argc; i++ ) {
! 356: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
! 357: }
! 358: if ( n0 )
! 359: NEXT(n) = 0;
! 360: MKLIST(*rp,n0);
! 361: }
! 362: }
! 363:
! 364: void Pfunargs(NODE arg,LIST *rp)
! 365: {
! 366: P p;
! 367: P f;
! 368: FUNC t;
! 369: PF pf;
! 370: PFINS ins;
! 371: PFAD ad;
! 372: NODE n,n0;
! 373: int i;
! 374:
! 375: p = (P)ARG0(arg);
! 376: if ( !ISPFINS(p) )
! 377: *rp = 0;
! 378: else {
! 379: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
! 380: t = (FUNC)MALLOC(sizeof(struct oFUNC));
! 381: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
! 382: t->f.puref = pf;
! 383: makesrvar(t,&f);
! 384: n = n0 = 0; NEXTNODE(n0,n); BDY(n) = (pointer)f;
! 385: for ( i = 0; i < pf->argc; i++ ) {
! 386: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
! 387: }
! 388: NEXT(n) = 0;
! 389: MKLIST(*rp,n0);
! 390: }
! 391: }
! 392:
! 393: void Pfunargs_ext(NODE arg,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: Z 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);
! 424: MKLIST(*rp,n0);
! 425: }
! 426: }
! 427:
! 428: void Pvtype(NODE arg,Z *rp)
! 429: {
! 430: P p;
! 431:
! 432: p = (P)ARG0(arg);
! 433: if ( !p || ID(p) != O_P )
! 434: *rp = 0;
! 435: else
! 436: STOQ((long)VR(p)->attr,*rp);
! 437: }
! 438:
! 439: extern NODE user_int_handler,user_quit_handler;
! 440:
! 441: void Pregister_handler(NODE arg,Z *rp)
! 442: {
! 443: P p;
! 444: V v;
! 445: NODE n;
! 446: FUNC func;
! 447:
! 448: p = (P)ARG0(arg);
! 449: if ( !p ) {
! 450: user_int_handler = 0;
! 451: *rp = 0;
! 452: return;
! 453: } else if ( OID(p) != 2 )
! 454: error("register_hanlder : invalid argument");
! 455: v = VR(p);
! 456: if ( (long)v->attr != V_SR )
! 457: error("register_hanlder : no such function");
! 458: else {
! 459: func = (FUNC)v->priv;
! 460: if ( func->argc )
! 461: error("register_hanlder : the function must be with no argument");
! 462: else {
! 463: MKNODE(n,(pointer)func,user_int_handler);
! 464: user_int_handler = n;
! 465: *rp = ONE;
! 466: }
! 467: }
! 468: }
! 469:
! 470: void Padd_handler(NODE arg,Z *rp)
! 471: {
! 472: P p;
! 473: V v;
! 474: NODE n;
! 475: FUNC func;
! 476: char *name;
! 477: NODE *hlistp;
! 478:
! 479: asir_assert(ARG0(arg),O_STR,"add_handler");
! 480: name = BDY((STRING)ARG0(arg));
! 481: p = (P)ARG1(arg);
! 482: if ( !strcmp(name,"intr") )
! 483: hlistp = &user_int_handler;
! 484: else if ( !strcmp(name,"quit") )
! 485: hlistp = &user_quit_handler;
! 486: else
! 487: error("add_handler : invalid keyword (must be \"intr\" or \"quit\")");
! 488: if ( !p ) {
! 489: *hlistp = 0; *rp = 0;
! 490: return;
! 491: }
! 492: if ( OID(p) == 2 ) {
! 493: v = VR(p);
! 494: if ( (long)v->attr != V_SR )
! 495: error("add_hanlder : no such function");
! 496: func = (FUNC)v->priv;
! 497: } else if ( OID(p) == O_STR ) {
! 498: gen_searchf_searchonly(BDY((STRING)p),&func,0);
! 499: if ( !func )
! 500: error("add_hanlder : no such function");
! 501: }
! 502: if ( func->argc )
! 503: error("register_hanlder : the function must be with no argument");
! 504: else {
! 505: MKNODE(n,(pointer)func,*hlistp);
! 506: *hlistp = n;
! 507: *rp = ONE;
! 508: }
! 509: }
! 510:
! 511: void Plist_handler(NODE arg,LIST *rp)
! 512: {
! 513: NODE r0,r,t;
! 514: char *name;
! 515: NODE hlist;
! 516: STRING fname;
! 517:
! 518: asir_assert(ARG0(arg),O_STR,"list_handler");
! 519: name = BDY((STRING)ARG0(arg));
! 520: if ( !strcmp(name,"intr") )
! 521: hlist = user_int_handler;
! 522: else if ( !strcmp(name,"quit") )
! 523: hlist = user_quit_handler;
! 524: else
! 525: error("list_handler : invalid keyword (must be \"intr\" or \"quit\")");
! 526: for ( r0 = 0, t = hlist; t; t = NEXT(t) ) {
! 527: NEXTNODE(r0,r);
! 528: MKSTR(fname,((FUNC)BDY(t))->fullname);
! 529: BDY(r) = (pointer)fname;
! 530: }
! 531: if ( r0 ) NEXT(r) = 0;
! 532: MKLIST(*rp,r0);
! 533: }
! 534:
! 535: void Pclear_handler(NODE arg,Z *rp)
! 536: {
! 537: NODE r0,r,t;
! 538: char *name;
! 539: NODE hlist;
! 540: STRING fname;
! 541:
! 542: asir_assert(ARG0(arg),O_STR,"clear_handler");
! 543: name = BDY((STRING)ARG0(arg));
! 544: if ( !strcmp(name,"intr") )
! 545: user_int_handler = 0;
! 546: else if ( !strcmp(name,"quit") )
! 547: user_quit_handler = 0;
! 548: else
! 549: error("clear_handler : invalid keyword (must be \"intr\" or \"quit\")");
! 550: *rp = 0;
! 551: }
! 552:
! 553: void Pcall(NODE arg,Obj *rp)
! 554: {
! 555: P p;
! 556: V v;
! 557: NODE n,n1;
! 558: LIST list;
! 559: VECT vect;
! 560: pointer *a;
! 561: int len,i;
! 562:
! 563: p = (P)ARG0(arg);
! 564: if ( !p || OID(p) != 2 )
! 565: error("call : invalid argument");
! 566: v = VR(p);
! 567: if ( (long)v->attr != V_SR )
! 568: error("call : no such function");
! 569: else {
! 570: list = (LIST) ARG1(arg);
! 571: if ( list ) {
! 572: switch (OID(list)) {
! 573: case O_VECT:
! 574: vect = (VECT)list; len = vect->len; a = BDY(vect);
! 575: for ( i = len - 1, n = 0; i >= 0; i-- ) {
! 576: MKNODE(n1,a[i],n); n = n1;
! 577: }
! 578: MKLIST(list,n);
! 579: /* falling next case */
! 580: case O_LIST:
! 581: *rp = (Obj)bevalf_with_opts((FUNC)v->priv,BDY(list),current_option);
! 582: return;
! 583: default:
! 584: break;
! 585: }
! 586: }
! 587: error("call : invalid argument");
! 588: }
! 589: }
! 590:
! 591: /* at=position of arg to be used for iteration */
! 592:
! 593: void Pmapat(NODE arg,Obj *rp)
! 594: {
! 595: LIST args;
! 596: NODE node,rest,t0,t,n,r,r0;
! 597: P fpoly;
! 598: V fvar;
! 599: FUNC f;
! 600: VECT v,rv;
! 601: MAT m,rm;
! 602: LIST rl;
! 603: int len,row,col,i,j,pos;
! 604: Obj iter;
! 605: pointer val;
! 606: NODE option;
! 607:
! 608: option = current_option;
! 609:
! 610: if ( argc(arg) < 3 )
! 611: error("mapat : too few arguments");
! 612:
! 613: fpoly = (P)ARG0(arg);
! 614: if ( !fpoly || OID(fpoly) != O_P )
! 615: error("mapat : invalid function specification");
! 616: fvar = VR(fpoly);
! 617: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
! 618: error("mapat : invalid function specification");
! 619: if ( !INT(ARG1(arg)) )
! 620: error("mapat : invalid position");
! 621: pos = QTOS((Q)ARG1(arg));
! 622: node = NEXT(NEXT(arg));
! 623: len = length(node);
! 624: if ( pos >= len )
! 625: error("evalmapatf : invalid position");
! 626: r0 = 0;
! 627: for ( i = 0, t = node; i < pos; i++, t = NEXT(t) ) {
! 628: NEXTNODE(r0,r);
! 629: BDY(r) = BDY(t);
! 630: }
! 631: NEXTNODE(r0,r);
! 632: iter = BDY(t); rest = NEXT(t);
! 633: if ( !iter ) {
! 634: *rp = bevalf_with_opts(f,node,option);
! 635: return;
! 636: }
! 637: switch ( OID(iter) ) {
! 638: case O_VECT:
! 639: v = (VECT)iter; len = v->len; MKVECT(rv,len);
! 640: for ( i = 0; i < len; i++ ) {
! 641: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
! 642: BDY(rv)[i] = bevalf_with_opts(f,r0,option);
! 643: }
! 644: *rp = (Obj)rv;
! 645: break;
! 646: case O_MAT:
! 647: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
! 648: for ( i = 0; i < row; i++ )
! 649: for ( j = 0; j < col; j++ ) {
! 650: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
! 651: BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);
! 652: }
! 653: *rp = (Obj)rm;
! 654: break;
! 655: case O_LIST:
! 656: n = BDY((LIST)iter);
! 657: for ( t0 = t = 0; n; n = NEXT(n) ) {
! 658: BDY(r) = BDY(n); NEXT(r) = rest;
! 659: NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);
! 660: }
! 661: if ( t0 )
! 662: NEXT(t) = 0;
! 663: MKLIST(rl,t0);
! 664: *rp = (Obj)rl;
! 665: break;
! 666: default:
! 667: *rp = bevalf_with_opts(f,node,option);
! 668: break;
! 669: }
! 670: }
! 671:
! 672: /* An implementation of 'map' as builtin function. */
! 673: void Pmap(NODE arg,Obj *rp)
! 674: {
! 675: LIST args;
! 676: NODE node,rest,t0,t,n,r,r0;
! 677: P fpoly;
! 678: V fvar;
! 679: FUNC f;
! 680: VECT v,rv;
! 681: MAT m,rm;
! 682: LIST rl;
! 683: int len,row,col,i,j;
! 684: Obj iter;
! 685: pointer val;
! 686: NODE option;
! 687:
! 688: option = current_option;
! 689:
! 690: if ( argc(arg) < 2 )
! 691: error("mapat : too few arguments");
! 692:
! 693: fpoly = (P)ARG0(arg);
! 694: if ( !fpoly || OID(fpoly) != O_P )
! 695: error("map : invalid function specification");
! 696: fvar = VR(fpoly);
! 697: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
! 698: error("map : invalid function specification");
! 699:
! 700: node = NEXT(arg);
! 701: len = length(node);
! 702: if ( 0 >= len )
! 703: error("evalmapf : invalid position");
! 704: r0 = 0;
! 705: NEXTNODE(r0,r);
! 706: iter = BDY(node); rest = NEXT(node);
! 707: if ( !iter ) {
! 708: *rp = bevalf_with_opts(f,node,option);
! 709: return;
! 710: }
! 711: switch ( OID(iter) ) {
! 712: case O_VECT:
! 713: v = (VECT)iter; len = v->len; MKVECT(rv,len);
! 714: for ( i = 0; i < len; i++ ) {
! 715: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
! 716: BDY(rv)[i] = bevalf_with_opts(f,r0,option);
! 717: }
! 718: *rp = (Obj)rv;
! 719: break;
! 720: case O_MAT:
! 721: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
! 722: for ( i = 0; i < row; i++ )
! 723: for ( j = 0; j < col; j++ ) {
! 724: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
! 725: BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);
! 726: }
! 727: *rp = (Obj)rm;
! 728: break;
! 729: case O_LIST:
! 730: n = BDY((LIST)iter);
! 731: for ( t0 = t = 0; n; n = NEXT(n) ) {
! 732: BDY(r) = BDY(n); NEXT(r) = rest;
! 733: NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);
! 734: }
! 735: if ( t0 )
! 736: NEXT(t) = 0;
! 737: MKLIST(rl,t0);
! 738: *rp = (Obj)rl;
! 739: break;
! 740: default:
! 741: *rp = bevalf_with_opts(f,node,option);
! 742: break;
! 743: }
! 744: }
! 745:
! 746: void Pdeval(NODE arg,Obj *rp)
! 747: {
! 748: asir_assert(ARG0(arg),O_R,"deval");
! 749: devalr(CO,(Obj)ARG0(arg),rp);
! 750: }
! 751:
! 752: void Peval_quote(NODE arg,Obj *rp)
! 753: {
! 754: FNODE a;
! 755: QUOTE q;
! 756: Obj f;
! 757:
! 758: f = (Obj)ARG0(arg);
! 759: if ( !f || OID(f) != O_QUOTE ) {
! 760: *rp = f;
! 761: return;
! 762: }
! 763: if ( argc(arg) == 2 && ARG1(arg) ) {
! 764: a = partial_eval((FNODE)BDY((QUOTE)ARG0(arg)));
! 765: MKQUOTE(q,a);
! 766: *rp = (Obj)q;
! 767: } else
! 768: *rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));
! 769: }
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