=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/pf.c,v retrieving revision 1.1.1.1 retrieving revision 1.22 diff -u -p -r1.1.1.1 -r1.22 --- OpenXM_contrib2/asir2000/builtin/pf.c 1999/12/03 07:39:07 1.1.1.1 +++ OpenXM_contrib2/asir2000/builtin/pf.c 2015/08/14 13:51:54 1.22 @@ -1,4 +1,52 @@ -/* $OpenXM: OpenXM/src/asir99/builtin/pf.c,v 1.1.1.1 1999/11/10 08:12:26 noro Exp $ */ +/* + * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED + * All rights reserved. + * + * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited, + * non-exclusive and royalty-free license to use, copy, modify and + * redistribute, solely for non-commercial and non-profit purposes, the + * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and + * conditions of this Agreement. For the avoidance of doubt, you acquire + * only a limited right to use the SOFTWARE hereunder, and FLL or any + * third party developer retains all rights, including but not limited to + * copyrights, in and to the SOFTWARE. + * + * (1) FLL does not grant you a license in any way for commercial + * purposes. You may use the SOFTWARE only for non-commercial and + * non-profit purposes only, such as academic, research and internal + * business use. + * (2) The SOFTWARE is protected by the Copyright Law of Japan and + * international copyright treaties. If you make copies of the SOFTWARE, + * with or without modification, as permitted hereunder, you shall affix + * to all such copies of the SOFTWARE the above copyright notice. + * (3) An explicit reference to this SOFTWARE and its copyright owner + * shall be made on your publication or presentation in any form of the + * results obtained by use of the SOFTWARE. + * (4) In the event that you modify the SOFTWARE, you shall notify FLL by + * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification + * for such modification or the source code of the modified part of the + * SOFTWARE. + * + * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL + * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND + * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS + * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES' + * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY + * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY. + * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT, + * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY + * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL + * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES + * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES + * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY + * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF + * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART + * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY + * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, + * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. + * + * $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.21 2015/08/06 10:01:52 fujimoto Exp $ +*/ #include "ca.h" #include "math.h" #include "parse.h" @@ -14,33 +62,40 @@ void make_itri(void); void make_tri(void); void make_exp(void); void simplify_pow(PFINS,Obj *); +FNODE partial_eval(FNODE f); -void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(); +void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(),Pfunargs_ext(); void Pregister_handler(); +void Peval_quote(); +void Pmapat(), Pmap(); +void Padd_handler(); +void Plist_handler(); +void Pclear_handler(); struct ftab puref_tab[] = { + {"mapat",Pmapat,-99999999}, + {"map",Pmap,-99999999}, {"functor",Pfunctor,1}, {"args",Pargs,1}, {"funargs",Pfunargs,1}, + {"funargs_ext",Pfunargs_ext,1}, {"register_handler",Pregister_handler,1}, + {"add_handler",Padd_handler,2}, + {"list_handler",Plist_handler,1}, + {"clear_handler",Pclear_handler,1}, {"call",Pcall,2}, {"vtype",Pvtype,1}, {"deval",Pdeval,1}, + {"eval_quote",Peval_quote,-2}, {0,0,0}, }; -#if PARI -int p_pi(),p_e(); -int p_log(),p_exp(),p_pow(); -int p_sin(),p_cos(),p_tan(),p_asin(),p_acos(),p_atan(); -int p_sinh(),p_cosh(),p_tanh(),p_asinh(),p_acosh(),p_atanh(); -#else -int p_pi,p_e; -int p_log,p_exp,p_pow; -int p_sin,p_cos,p_tan,p_asin,p_acos,p_atan; -int p_sinh,p_cosh,p_tanh,p_asinh,p_acosh,p_atanh; -#endif +int mp_pi(),mp_e(); +int mp_exp(), mp_log(), mp_pow(); +int mp_sin(),mp_cos(),mp_tan(),mp_asin(),mp_acos(),mp_atan(); +int mp_sinh(),mp_cosh(),mp_tanh(),mp_asinh(),mp_acosh(),mp_atanh(); + static V *uarg,*darg; static P x,y; static PF pidef,edef; @@ -55,6 +110,8 @@ static PF asinhdef,acoshdef,atanhdef; double const_pi() { return 3.14159265358979323846264338327950288; } double const_e() { return 2.718281828459045235360287471352662497; } +int simplify_elemfunc_ins(); + void pf_init() { uarg = (V *)CALLOC(1,sizeof(V)); uarg[0] = &oVAR[26]; MKV(uarg[0],x); @@ -63,33 +120,33 @@ void pf_init() { darg[0] = &oVAR[26]; darg[1] = &oVAR[27]; MKV(darg[1],y); - mkpf("@pi",0,0,0,(int (*)())p_pi,const_pi,0,&pidef); - mkpf("@e",0,0,0,(int (*)())p_e,const_e,0,&edef); + mkpf("@pi",0,0,0,(int (*)())mp_pi,const_pi,0,&pidef); + mkpf("@e",0,0,0,(int (*)())mp_e,const_e,0,&edef); - mkpf("log",0,1,uarg,(int (*)())p_log,log,0,&logdef); - mkpf("exp",0,1,uarg,(int (*)())p_exp,exp,0,&expdef); - mkpf("pow",0,2,darg,(int (*)())p_pow,pow,(int (*)())simplify_pow,&powdef); + mkpf("log",0,1,uarg,(int (*)())mp_log,log,simplify_elemfunc_ins,&logdef); + mkpf("exp",0,1,uarg,(int (*)())mp_exp,exp,simplify_elemfunc_ins,&expdef); + mkpf("pow",0,2,darg,(int (*)())mp_pow,pow,(int (*)())simplify_pow,&powdef); - mkpf("sin",0,1,uarg,(int (*)())p_sin,sin,0,&sindef); - mkpf("cos",0,1,uarg,(int (*)())p_cos,cos,0,&cosdef); - mkpf("tan",0,1,uarg,(int (*)())p_tan,tan,0,&tandef); - mkpf("asin",0,1,uarg,(int (*)())p_asin,asin,0,&asindef); - mkpf("acos",0,1,uarg,(int (*)())p_acos,acos,0,&acosdef); - mkpf("atan",0,1,uarg,(int (*)())p_atan,atan,0,&atandef); + mkpf("sin",0,1,uarg,(int (*)())mp_sin,sin,simplify_elemfunc_ins,&sindef); + mkpf("cos",0,1,uarg,(int (*)())mp_cos,cos,simplify_elemfunc_ins,&cosdef); + mkpf("tan",0,1,uarg,(int (*)())mp_tan,tan,simplify_elemfunc_ins,&tandef); + mkpf("asin",0,1,uarg,(int (*)())mp_asin,asin,simplify_elemfunc_ins,&asindef); + mkpf("acos",0,1,uarg,(int (*)())mp_acos,acos,simplify_elemfunc_ins,&acosdef); + mkpf("atan",0,1,uarg,(int (*)())mp_atan,atan,simplify_elemfunc_ins,&atandef); - mkpf("sinh",0,1,uarg,(int (*)())p_sinh,sinh,0,&sinhdef); - mkpf("cosh",0,1,uarg,(int (*)())p_cosh,cosh,0,&coshdef); - mkpf("tanh",0,1,uarg,(int (*)())p_tanh,tanh,0,&tanhdef); -#if !defined(VISUAL) - mkpf("asinh",0,1,uarg,(int (*)())p_asinh,asinh,0,&asinhdef); - mkpf("acosh",0,1,uarg,(int (*)())p_acosh,acosh,0,&acoshdef); - mkpf("atanh",0,1,uarg,(int (*)())p_atanh,atanh,0,&atanhdef); + mkpf("sinh",0,1,uarg,(int (*)())mp_sinh,sinh,simplify_elemfunc_ins,&sinhdef); + mkpf("cosh",0,1,uarg,(int (*)())mp_cosh,cosh,simplify_elemfunc_ins,&coshdef); + mkpf("tanh",0,1,uarg,(int (*)())mp_tanh,tanh,simplify_elemfunc_ins,&tanhdef); +#if !defined(VISUAL) && !defined(__MINGW32__) + mkpf("asinh",0,1,uarg,(int (*)())mp_asinh,asinh,simplify_elemfunc_ins,&asinhdef); + mkpf("acosh",0,1,uarg,(int (*)())mp_acosh,acosh,simplify_elemfunc_ins,&acoshdef); + mkpf("atanh",0,1,uarg,(int (*)())mp_atanh,atanh,simplify_elemfunc_ins,&atanhdef); #endif make_exp(); make_tri(); make_itri(); make_hyp(); -#if !defined(VISUAL) +#if !defined(VISUAL) && !defined(__MINGW32__) make_ihyp(); #endif } @@ -232,9 +289,15 @@ Obj *rp; pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg; if ( !a1 ) *rp = (Obj)ONE; - else if ( !a0 ) - *rp = 0; - else if ( NUM(a1) && INT(a1) ) + else if ( !a0 ) { + if ( RATN(a1) && SGN((Q)a1)>0 ) + *rp = 0; + else if ( RATN(a1) && SGN((Q)a1) < 0 ) + error("simplify_pow : division by 0"); + else { + instov(ins,&v); MKV(v,t); *rp = (Obj)t; + } + } else if ( NUM(a1) && INT(a1) ) arf_pwr(CO,a0,a1,rp); else { instov(ins,&v); MKV(v,t); *rp = (Obj)t; @@ -242,8 +305,8 @@ Obj *rp; } #define ISPFINS(p)\ -(p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr!=V_PF)&&\ -UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p))) +((p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr==V_PF)&&\ +UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p)))) void Pfunctor(arg,rp) NODE arg; @@ -260,7 +323,7 @@ P *rp; else { ins = (PFINS)VR(p)->priv; pf = ins->pf; t = (FUNC)MALLOC(sizeof(struct oFUNC)); - t->name = pf->name; t->id = A_PURE; t->argc = pf->argc; + t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc; t->f.puref = pf; makesrvar(t,rp); } @@ -310,10 +373,10 @@ LIST *rp; else { ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf; t = (FUNC)MALLOC(sizeof(struct oFUNC)); - t->name = pf->name; t->id = A_PURE; t->argc = pf->argc; + t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc; t->f.puref = pf; makesrvar(t,&f); - n0 = 0; NEXTNODE(n0,n); BDY(n) = (pointer)f; + n = n0 = 0; NEXTNODE(n0,n); BDY(n) = (pointer)f; for ( i = 0; i < pf->argc; i++ ) { NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg; } @@ -322,6 +385,43 @@ LIST *rp; } } +void Pfunargs_ext(arg,rp) +NODE arg; +LIST *rp; +{ + P p; + P f; + FUNC t; + PF pf; + PFINS ins; + PFAD ad; + NODE n,n0,d,d0,a,a0; + LIST alist,dlist; + Q q; + int i; + + p = (P)ARG0(arg); + if ( !ISPFINS(p) ) + *rp = 0; + else { + ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf; + t = (FUNC)MALLOC(sizeof(struct oFUNC)); + t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc; + t->f.puref = pf; + makesrvar(t,&f); + + d0 = a0 = 0; + for ( i = 0; i < pf->argc; i++ ) { + NEXTNODE(d0,d); STOQ(ad[i].d,q); BDY(d) = (pointer)q; + NEXTNODE(a0,a); BDY(a) = (pointer)ad[i].arg; + } + NEXT(d) = 0; NEXT(a) = 0; MKLIST(alist,a0); MKLIST(dlist,d0); + + n0 = mknode(3,f,dlist,alist); + MKLIST(*rp,n0); + } +} + void Pvtype(arg,rp) NODE arg; Q *rp; @@ -335,7 +435,7 @@ Q *rp; STOQ((int)VR(p)->attr,*rp); } -extern FUNC registered_handler; +extern NODE user_int_handler,user_quit_handler; void Pregister_handler(arg,rp) NODE arg; @@ -343,12 +443,15 @@ Q *rp; { P p; V v; + NODE n; FUNC func; p = (P)ARG0(arg); - if ( !p ) - registered_handler = 0; - else if ( OID(p) != 2 ) + if ( !p ) { + user_int_handler = 0; + *rp = 0; + return; + } else if ( OID(p) != 2 ) error("register_hanlder : invalid argument"); v = VR(p); if ( (int)v->attr != V_SR ) @@ -358,30 +461,295 @@ Q *rp; if ( func->argc ) error("register_hanlder : the function must be with no argument"); else { - registered_handler = func; + MKNODE(n,(pointer)func,user_int_handler); + user_int_handler = n; *rp = ONE; - } + } } } -void Pcall(arg,rp) +void Padd_handler(arg,rp) NODE arg; -Obj *rp; +Q *rp; { P p; V v; + NODE n; + FUNC func; + char *name; + NODE *hlistp; + asir_assert(ARG0(arg),O_STR,"add_handler"); + name = BDY((STRING)ARG0(arg)); + p = (P)ARG1(arg); + if ( !strcmp(name,"intr") ) + hlistp = &user_int_handler; + else if ( !strcmp(name,"quit") ) + hlistp = &user_quit_handler; + else + error("add_handler : invalid keyword (must be \"intr\" or \"quit\")"); + if ( !p ) { + *hlistp = 0; *rp = 0; + return; + } + if ( OID(p) == 2 ) { + v = VR(p); + if ( (int)v->attr != V_SR ) + error("add_hanlder : no such function"); + func = (FUNC)v->priv; + } else if ( OID(p) == O_STR ) { + gen_searchf_searchonly(BDY((STRING)p),&func); + if ( !func ) + error("add_hanlder : no such function"); + } + if ( func->argc ) + error("register_hanlder : the function must be with no argument"); + else { + MKNODE(n,(pointer)func,*hlistp); + *hlistp = n; + *rp = ONE; + } +} + +void Plist_handler(arg,rp) +NODE arg; +LIST *rp; +{ + NODE r0,r,t; + char *name; + NODE hlist; + STRING fname; + + asir_assert(ARG0(arg),O_STR,"list_handler"); + name = BDY((STRING)ARG0(arg)); + if ( !strcmp(name,"intr") ) + hlist = user_int_handler; + else if ( !strcmp(name,"quit") ) + hlist = user_quit_handler; + else + error("list_handler : invalid keyword (must be \"intr\" or \"quit\")"); + for ( r0 = 0, t = hlist; t; t = NEXT(t) ) { + NEXTNODE(r0,r); + MKSTR(fname,((FUNC)BDY(t))->fullname); + BDY(r) = (pointer)fname; + } + if ( r0 ) NEXT(r) = 0; + MKLIST(*rp,r0); +} + +void Pclear_handler(arg,rp) +NODE arg; +Q *rp; +{ + NODE r0,r,t; + char *name; + NODE hlist; + STRING fname; + + asir_assert(ARG0(arg),O_STR,"clear_handler"); + name = BDY((STRING)ARG0(arg)); + if ( !strcmp(name,"intr") ) + user_int_handler = 0; + else if ( !strcmp(name,"quit") ) + user_quit_handler = 0; + else + error("clear_handler : invalid keyword (must be \"intr\" or \"quit\")"); + *rp = 0; +} + +void Pcall(NODE arg,Obj *rp) +{ + P p; + V v; + NODE n,n1; + LIST list; + VECT vect; + pointer *a; + int len,i; + p = (P)ARG0(arg); if ( !p || OID(p) != 2 ) error("call : invalid argument"); v = VR(p); if ( (int)v->attr != V_SR ) error("call : no such function"); + else { + list = (LIST) ARG1(arg); + if ( list ) { + switch (OID(list)) { + case O_VECT: + vect = (VECT)list; len = vect->len; a = BDY(vect); + for ( i = len - 1, n = 0; i >= 0; i-- ) { + MKNODE(n1,a[i],n); n = n1; + } + MKLIST(list,n); + /* falling next case */ + case O_LIST: + *rp = (Obj)bevalf_with_opts((FUNC)v->priv,BDY(list),current_option); + return; + default: + break; + } + } + error("call : invalid argument"); + } +} - else - *rp = (Obj)bevalf((FUNC)v->priv,BDY((LIST)ARG1(arg))); +/* at=position of arg to be used for iteration */ + +void Pmapat(NODE arg,Obj *rp) +{ + LIST args; + NODE node,rest,t0,t,n,r,r0; + P fpoly; + V fvar; + FUNC f; + VECT v,rv; + MAT m,rm; + LIST rl; + int len,row,col,i,j,pos; + Obj iter; + pointer val; + NODE option; + + option = current_option; + + if ( argc(arg) < 3 ) + error("mapat : too few arguments"); + + fpoly = (P)ARG0(arg); + if ( !fpoly || OID(fpoly) != O_P ) + error("mapat : invalid function specification"); + fvar = VR(fpoly); + if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) ) + error("mapat : invalid function specification"); + if ( !INT(ARG1(arg)) ) + error("mapat : invalid position"); + pos = QTOS((Q)ARG1(arg)); + node = NEXT(NEXT(arg)); + len = length(node); + if ( pos >= len ) + error("evalmapatf : invalid position"); + r0 = 0; + for ( i = 0, t = node; i < pos; i++, t = NEXT(t) ) { + NEXTNODE(r0,r); + BDY(r) = BDY(t); + } + NEXTNODE(r0,r); + iter = BDY(t); rest = NEXT(t); + if ( !iter ) { + *rp = bevalf_with_opts(f,node,option); + return; + } + switch ( OID(iter) ) { + case O_VECT: + v = (VECT)iter; len = v->len; MKVECT(rv,len); + for ( i = 0; i < len; i++ ) { + BDY(r) = BDY(v)[i]; NEXT(r) = rest; + BDY(rv)[i] = bevalf_with_opts(f,r0,option); + } + *rp = (Obj)rv; + break; + case O_MAT: + m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col); + for ( i = 0; i < row; i++ ) + for ( j = 0; j < col; j++ ) { + BDY(r) = BDY(m)[i][j]; NEXT(r) = rest; + BDY(rm)[i][j] = bevalf_with_opts(f,r0,option); + } + *rp = (Obj)rm; + break; + case O_LIST: + n = BDY((LIST)iter); + for ( t0 = t = 0; n; n = NEXT(n) ) { + BDY(r) = BDY(n); NEXT(r) = rest; + NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option); + } + if ( t0 ) + NEXT(t) = 0; + MKLIST(rl,t0); + *rp = (Obj)rl; + break; + default: + *rp = bevalf_with_opts(f,node,option); + break; + } } +/* An implementation of 'map' as builtin function. */ +void Pmap(NODE arg,Obj *rp) +{ + LIST args; + NODE node,rest,t0,t,n,r,r0; + P fpoly; + V fvar; + FUNC f; + VECT v,rv; + MAT m,rm; + LIST rl; + int len,row,col,i,j; + Obj iter; + pointer val; + NODE option; + + option = current_option; + + if ( argc(arg) < 2 ) + error("mapat : too few arguments"); + + fpoly = (P)ARG0(arg); + if ( !fpoly || OID(fpoly) != O_P ) + error("map : invalid function specification"); + fvar = VR(fpoly); + if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) ) + error("map : invalid function specification"); + + node = NEXT(arg); + len = length(node); + if ( 0 >= len ) + error("evalmapf : invalid position"); + r0 = 0; + NEXTNODE(r0,r); + iter = BDY(node); rest = NEXT(node); + if ( !iter ) { + *rp = bevalf_with_opts(f,node,option); + return; + } + switch ( OID(iter) ) { + case O_VECT: + v = (VECT)iter; len = v->len; MKVECT(rv,len); + for ( i = 0; i < len; i++ ) { + BDY(r) = BDY(v)[i]; NEXT(r) = rest; + BDY(rv)[i] = bevalf_with_opts(f,r0,option); + } + *rp = (Obj)rv; + break; + case O_MAT: + m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col); + for ( i = 0; i < row; i++ ) + for ( j = 0; j < col; j++ ) { + BDY(r) = BDY(m)[i][j]; NEXT(r) = rest; + BDY(rm)[i][j] = bevalf_with_opts(f,r0,option); + } + *rp = (Obj)rm; + break; + case O_LIST: + n = BDY((LIST)iter); + for ( t0 = t = 0; n; n = NEXT(n) ) { + BDY(r) = BDY(n); NEXT(r) = rest; + NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option); + } + if ( t0 ) + NEXT(t) = 0; + MKLIST(rl,t0); + *rp = (Obj)rl; + break; + default: + *rp = bevalf_with_opts(f,node,option); + break; + } +} + void Pdeval(arg,rp) NODE arg; Obj *rp; @@ -390,3 +758,23 @@ Obj *rp; devalr(CO,(Obj)ARG0(arg),rp); } +void Peval_quote(arg,rp) +NODE arg; +Obj *rp; +{ + FNODE a; + QUOTE q; + Obj f; + + f = (Obj)ARG0(arg); + if ( !f || OID(f) != O_QUOTE ) { + *rp = f; + return; + } + if ( argc(arg) == 2 && ARG1(arg) ) { + a = partial_eval((FNODE)BDY((QUOTE)ARG0(arg))); + MKQUOTE(q,a); + *rp = (Obj)q; + } else + *rp = eval((FNODE)BDY((QUOTE)ARG0(arg))); +}