=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/parif.c,v retrieving revision 1.1.1.1 retrieving revision 1.8 diff -u -p -r1.1.1.1 -r1.8 --- OpenXM_contrib2/asir2000/builtin/parif.c 1999/12/03 07:39:07 1.1.1.1 +++ OpenXM_contrib2/asir2000/builtin/parif.c 2001/07/05 09:26:43 1.8 @@ -1,4 +1,52 @@ -/* $OpenXM: OpenXM/src/asir99/builtin/parif.c,v 1.2 1999/11/18 05:42:01 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/parif.c,v 1.7 2000/12/22 09:58:32 saito Exp $ +*/ #include "ca.h" #include "parse.h" @@ -7,30 +55,33 @@ extern long prec; -#if defined(THINK_C) void patori(GEN,Obj *); void patori_i(GEN,N *); void ritopa(Obj,GEN *); void ritopa_i(N,int,GEN *); -#else -void patori(); -void patori_i(); -void ritopa(); -void ritopa_i(); -#endif void Peval(),Psetprec(),p_pi(),p_e(),p_mul(),p_gcd(); +void asir_cgiv(GEN); +#if defined(INTERVAL) || 1 +void Psetprecword(); +#endif + struct ftab pari_tab[] = { - {"eval",Peval,-2}, {"setprec",Psetprec,-1}, {0,0,0}, + {"eval",Peval,-2}, + {"setprec",Psetprec,-1}, +#if defined(INTERVAL) || 1 + {"setprecword",Psetprecword,-1}, +#endif + {0,0,0}, }; #define MKPREC(a,i,b) (argc(a)==(i)?mkprec(QTOS((Q)(b))):prec) #define CALLPARI1(f,a,p,r)\ -ritopa((Obj)a,&_pt1_); _pt2_ = f(_pt1_,p); patori(_pt2_,r); cgiv(_pt2_); cgiv(_pt1_) +ritopa((Obj)a,&_pt1_); _pt2_ = f(_pt1_,p); patori(_pt2_,r); asir_cgiv(_pt2_); asir_cgiv(_pt1_) #define CALLPARI2(f,a,b,p,r)\ -ritopa((Obj)a,&_pt1_); ritopa((Obj)b,&_pt2_); _pt3_ = f(_pt1_,_pt2_,p); patori(_pt3_,r); cgiv(_pt3_); cgiv(_pt2_); cgiv(_pt1_) +ritopa((Obj)a,&_pt1_); ritopa((Obj)b,&_pt2_); _pt3_ = f(_pt1_,_pt2_,p); patori(_pt3_,r); asir_cgiv(_pt3_); asir_cgiv(_pt2_); asir_cgiv(_pt1_) #define PARIF1P(f,pf)\ void f(NODE,Obj *);\ @@ -41,13 +92,28 @@ void f(NODE,Obj *);\ void f(ar,rp) NODE ar; Obj *rp;\ { GEN _pt1_,_pt2_,_pt3_; CALLPARI2(pf,ARG0(ar),ARG1(ar),MKPREC(ar,3,ARG2(ar)),rp); } +#if defined(INTERVAL) +#define PREC_CONV pariK1 +#else #if defined(LONG_IS_32BIT) #define PREC_CONV 0.103810253 #endif #if defined(LONG_IS_64BIT) #define PREC_CONV 0.051905126 #endif +#endif +/* XXX : we should be more careful when we free PARI pointers. */ + +void asir_cgiv(ptr) +GEN ptr; +{ + if ( ptr != gzero && ptr != gun + && ptr != gdeux && ptr != ghalf + && ptr != polvar && ptr != gi ) + cgiv(ptr); +} + mkprec(p) int p; { @@ -70,13 +136,42 @@ Obj *rp; int p; Q q; +#if defined(INTERVAL) || 1 + p = (int)((prec-2)/PREC_CONV); STOQ(p,q); *rp = (Obj)q; + if ( arg ) { + asir_assert(ARG0(arg),O_N,"setprec"); + p = QTOS((Q)ARG0(arg)); + if ( p > 0 ) + prec = (long)(p*PREC_CONV+3); + } +#else p = (int)((prec-3)/PREC_CONV); STOQ(p,q); *rp = (Obj)q; if ( arg ) { asir_assert(ARG0(arg),O_N,"setprec"); prec = mkprec(QTOS((Q)ARG0(arg))); } +#endif } +#if defined(INTERVAL) || 1 +void Psetprecword(arg,rp) +NODE arg; +Obj *rp; +{ + int p; + Q q; + + p = (int)((prec-2)); STOQ(p,q); *rp = (Obj)q; + if ( arg ) { + asir_assert(ARG0(arg),O_N,"setprecword"); + p = QTOS((Q)ARG0(arg)); + if ( p > 0 ) { + prec = p + 2; + } + } +} +#endif + void p_pi(arg,rp) NODE arg; Obj *rp; @@ -84,7 +179,7 @@ Obj *rp; GEN x; x = mppi(MKPREC(arg,1,ARG0(arg))); - patori(x,rp); cgiv(x); + patori(x,rp); asir_cgiv(x); } void p_e(arg,rp) @@ -93,7 +188,7 @@ Obj *rp; { GEN x; - x = gexp(gun,MKPREC(arg,1,ARG0(arg))); patori(x,rp); cgiv(x); + x = gexp(gun,MKPREC(arg,1,ARG0(arg))); patori(x,rp); asir_cgiv(x); } void p_mul(a,b,r) @@ -103,7 +198,7 @@ Obj a,b,*r; ritopa((Obj)a,&p1); ritopa((Obj)b,&p2); p3 = mulii(p1,p2); - patori(p3,r); cgiv(p3); cgiv(p2); cgiv(p1); + patori(p3,r); asir_cgiv(p3); asir_cgiv(p2); asir_cgiv(p1); } void p_gcd(a,b,r) @@ -113,7 +208,7 @@ N a,b,*r; ritopa_i(a,1,&p1); ritopa_i(b,1,&p2); p3 = mppgcd(p1,p2); - patori_i(p3,r); cgiv(p3); cgiv(p2); cgiv(p1); + patori_i(p3,r); asir_cgiv(p3); asir_cgiv(p2); asir_cgiv(p1); } PARIF1P(p_sin,gsin) PARIF1P(p_cos,gcos) PARIF1P(p_tan,gtan) @@ -133,8 +228,9 @@ NODE arg; GEN a,v; long ltop,lbot; pointer r; - int ac; + int ac,opt; char buf[BUFSIZ]; + GEN (*dmy)(); if ( !f->f.binf ) { sprintf(buf,"pari : %s undefined.",f->name); @@ -149,19 +245,30 @@ NODE arg; } ltop = avma; ritopa((Obj)ARG0(arg),&a); -#if 1 || defined(__MWERKS__) - { - GEN (*dmy)(); - dmy = (GEN (*)())f->f.binf; v = (*dmy)(a,MKPREC(arg,2,ARG1(arg))); - } -#else - v = (GEN)(*f->f.binf)(a,MKPREC(arg,2,ARG1(arg))); -#endif lbot = avma; patori(v,(Obj *)&r); gerepile(ltop,lbot,0); return r; + + case 2: + ac = argc(arg); + if ( !ac || ( ac > 2 ) ) { + fprintf(stderr,"argument mismatch in %s()\n",NAME(f)); + error(""); + } + if ( ac == 1 ) + opt = 0; + else + opt = QTOS((Q)ARG1(arg)); + ltop = avma; + ritopa((Obj)ARG0(arg),&a); + dmy = (GEN (*)())f->f.binf; + v = (*dmy)(a,opt); + lbot = avma; + patori(v,(Obj *)&r); gerepile(ltop,lbot,0); + return r; + default: error("evalparif : not implemented yet."); } @@ -173,6 +280,12 @@ struct pariftab { int type; }; +/* + * type = 1 => argc = 1, second arg = precision + * type = 2 => argc = 1, second arg = optional (long int) + * + */ + struct pariftab pariftab[] = { {"abs",(GEN (*)())gabs,1}, {"adj",adj,1}, @@ -297,6 +410,7 @@ struct pariftab pariftab[] = { {"wf",wf,1}, {"wf2",wf2,1}, {"zeta",gzeta,1}, +{"factorint",factorint,2}, {0,0,0}, }; @@ -314,7 +428,10 @@ struct ftab pari_tab[] = { void parif_init() {} -pointer evalparif() { +pointer evalparif(f,arg) +FUNC f; +NODE arg; +{ error("evalparif : PARI is not combined."); } #endif /*PARI */