[BACK]Return to pf.c CVS log [TXT][DIR] Up to [local] / OpenXM_contrib2 / asir2000 / builtin

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>