[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.22

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>