OpenXM_contrib2/asir2000/builtin/parif.c - diff

Return to parif.c CVS log

Up to [local] / OpenXM_contrib2 / asir2000 / builtin

Diff for /OpenXM_contrib2/asir2000/builtin/parif.c between version 1.2 and 1.8

version 1.2, 2000/02/08 04:47:09

version 1.8, 2001/07/05 09:26:43

Line 1

/* $OpenXM: OpenXM_contrib2/asir2000/builtin/parif.c,v 1.1.1.1 1999/12/03 07:39:07 noro Exp $ */

* 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"

Line 7

Line 55

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 *);\

Line 41 void f(NODE,Obj *);\

Line 92 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

/* 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;

{

Line 70 Obj *rp;

Line 136 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;

Line 84 Obj *rp;

Line 179 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)

Line 93 Obj *rp;

Line 188 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)

Line 103 Obj a,b,*r;

Line 198 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)

Line 113 N a,b,*r;

Line 208 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)

Line 133 NODE arg;

Line 228 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);

Line 149 NODE arg;

Line 245 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.");

}

Line 173 struct pariftab {

Line 280 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},

Line 297 struct pariftab pariftab[] = {

Line 410 struct pariftab pariftab[] = {

{"wf",wf,1},

{"wf2",wf2,1},

{"zeta",gzeta,1},

{"factorint",factorint,2},

{0,0,0},

};

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