Annotation of OpenXM_contrib2/asir2000/builtin/parif.c, Revision 1.8
1.3 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.4 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.3 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.8 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/parif.c,v 1.7 2000/12/22 09:58:32 saito Exp $
1.3 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "parse.h"
52:
53: #if PARI
54: #include "genpari.h"
55:
56: extern long prec;
57:
58: void patori(GEN,Obj *);
59: void patori_i(GEN,N *);
60: void ritopa(Obj,GEN *);
61: void ritopa_i(N,int,GEN *);
62:
63: void Peval(),Psetprec(),p_pi(),p_e(),p_mul(),p_gcd();
1.5 noro 64: void asir_cgiv(GEN);
1.1 noro 65:
1.7 saito 66: #if defined(INTERVAL) || 1
67: void Psetprecword();
68: #endif
69:
1.1 noro 70: struct ftab pari_tab[] = {
1.7 saito 71: {"eval",Peval,-2},
72: {"setprec",Psetprec,-1},
73: #if defined(INTERVAL) || 1
74: {"setprecword",Psetprecword,-1},
75: #endif
76: {0,0,0},
1.1 noro 77: };
78:
79: #define MKPREC(a,i,b) (argc(a)==(i)?mkprec(QTOS((Q)(b))):prec)
80:
81: #define CALLPARI1(f,a,p,r)\
1.5 noro 82: ritopa((Obj)a,&_pt1_); _pt2_ = f(_pt1_,p); patori(_pt2_,r); asir_cgiv(_pt2_); asir_cgiv(_pt1_)
1.1 noro 83: #define CALLPARI2(f,a,b,p,r)\
1.5 noro 84: 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_)
1.1 noro 85:
86: #define PARIF1P(f,pf)\
87: void f(NODE,Obj *);\
88: void f(ar,rp) NODE ar; Obj *rp;\
89: { GEN _pt1_,_pt2_; CALLPARI1(pf,ARG0(ar),MKPREC(ar,2,ARG1(ar)),rp); }
90: #define PARIF2P(f,pf)\
91: void f(NODE,Obj *);\
92: void f(ar,rp) NODE ar; Obj *rp;\
93: { GEN _pt1_,_pt2_,_pt3_; CALLPARI2(pf,ARG0(ar),ARG1(ar),MKPREC(ar,3,ARG2(ar)),rp); }
94:
1.7 saito 95: #if defined(INTERVAL)
96: #define PREC_CONV pariK1
97: #else
1.1 noro 98: #if defined(LONG_IS_32BIT)
99: #define PREC_CONV 0.103810253
100: #endif
101: #if defined(LONG_IS_64BIT)
102: #define PREC_CONV 0.051905126
103: #endif
1.7 saito 104: #endif
1.1 noro 105:
1.5 noro 106: /* XXX : we should be more careful when we free PARI pointers. */
107:
108: void asir_cgiv(ptr)
109: GEN ptr;
110: {
111: if ( ptr != gzero && ptr != gun
112: && ptr != gdeux && ptr != ghalf
113: && ptr != polvar && ptr != gi )
114: cgiv(ptr);
115: }
116:
1.1 noro 117: mkprec(p)
118: int p;
119: {
120: if ( p > 0 )
121: return (int)(p*PREC_CONV+3);
122: }
123:
124: void Peval(arg,rp)
125: NODE arg;
126: Obj *rp;
127: {
128: asir_assert(ARG0(arg),O_R,"eval");
129: evalr(CO,(Obj)ARG0(arg),argc(arg)==2?QTOS((Q)ARG1(arg)):0,rp);
130: }
131:
132: void Psetprec(arg,rp)
133: NODE arg;
134: Obj *rp;
135: {
136: int p;
137: Q q;
138:
1.7 saito 139: #if defined(INTERVAL) || 1
140: p = (int)((prec-2)/PREC_CONV); STOQ(p,q); *rp = (Obj)q;
141: if ( arg ) {
142: asir_assert(ARG0(arg),O_N,"setprec");
143: p = QTOS((Q)ARG0(arg));
144: if ( p > 0 )
145: prec = (long)(p*PREC_CONV+3);
146: }
147: #else
1.1 noro 148: p = (int)((prec-3)/PREC_CONV); STOQ(p,q); *rp = (Obj)q;
149: if ( arg ) {
150: asir_assert(ARG0(arg),O_N,"setprec");
151: prec = mkprec(QTOS((Q)ARG0(arg)));
152: }
1.7 saito 153: #endif
1.1 noro 154: }
1.7 saito 155:
156: #if defined(INTERVAL) || 1
157: void Psetprecword(arg,rp)
158: NODE arg;
159: Obj *rp;
160: {
161: int p;
162: Q q;
163:
164: p = (int)((prec-2)); STOQ(p,q); *rp = (Obj)q;
165: if ( arg ) {
166: asir_assert(ARG0(arg),O_N,"setprecword");
167: p = QTOS((Q)ARG0(arg));
168: if ( p > 0 ) {
169: prec = p + 2;
170: }
171: }
172: }
173: #endif
1.1 noro 174:
175: void p_pi(arg,rp)
176: NODE arg;
177: Obj *rp;
178: {
179: GEN x;
180:
181: x = mppi(MKPREC(arg,1,ARG0(arg)));
1.5 noro 182: patori(x,rp); asir_cgiv(x);
1.1 noro 183: }
184:
185: void p_e(arg,rp)
186: NODE arg;
187: Obj *rp;
188: {
189: GEN x;
190:
1.5 noro 191: x = gexp(gun,MKPREC(arg,1,ARG0(arg))); patori(x,rp); asir_cgiv(x);
1.1 noro 192: }
193:
194: void p_mul(a,b,r)
195: Obj a,b,*r;
196: {
197: GEN p1,p2,p3;
198:
199: ritopa((Obj)a,&p1); ritopa((Obj)b,&p2);
200: p3 = mulii(p1,p2);
1.5 noro 201: patori(p3,r); asir_cgiv(p3); asir_cgiv(p2); asir_cgiv(p1);
1.1 noro 202: }
203:
204: void p_gcd(a,b,r)
205: N a,b,*r;
206: {
207: GEN p1,p2,p3;
208:
209: ritopa_i(a,1,&p1); ritopa_i(b,1,&p2);
210: p3 = mppgcd(p1,p2);
1.5 noro 211: patori_i(p3,r); asir_cgiv(p3); asir_cgiv(p2); asir_cgiv(p1);
1.1 noro 212: }
213:
214: PARIF1P(p_sin,gsin) PARIF1P(p_cos,gcos) PARIF1P(p_tan,gtan)
215: PARIF1P(p_asin,gasin) PARIF1P(p_acos,gacos) PARIF1P(p_atan,gatan)
216: PARIF1P(p_sinh,gsh) PARIF1P(p_cosh,gch) PARIF1P(p_tanh,gth)
217: PARIF1P(p_asinh,gash) PARIF1P(p_acosh,gach) PARIF1P(p_atanh,gath)
218: PARIF1P(p_exp,gexp) PARIF1P(p_log,glog)
219: PARIF1P(p_dilog,dilog) PARIF1P(p_erf,gerfc)
220: PARIF1P(p_eigen,eigen) PARIF1P(p_roots,roots)
221:
222: PARIF2P(p_pow,gpui)
223:
224: pointer evalparif(f,arg)
225: FUNC f;
226: NODE arg;
227: {
228: GEN a,v;
229: long ltop,lbot;
230: pointer r;
1.8 ! noro 231: int ac,opt;
1.1 noro 232: char buf[BUFSIZ];
1.8 ! noro 233: GEN (*dmy)();
1.1 noro 234:
235: if ( !f->f.binf ) {
236: sprintf(buf,"pari : %s undefined.",f->name);
237: error(buf);
238: }
239: switch ( f->type ) {
240: case 1:
241: ac = argc(arg);
242: if ( !ac || ( ac > 2 ) ) {
243: fprintf(stderr,"argument mismatch in %s()\n",NAME(f));
244: error("");
245: }
246: ltop = avma;
247: ritopa((Obj)ARG0(arg),&a);
248: dmy = (GEN (*)())f->f.binf;
249: v = (*dmy)(a,MKPREC(arg,2,ARG1(arg)));
250: lbot = avma;
251: patori(v,(Obj *)&r); gerepile(ltop,lbot,0);
252: return r;
1.8 ! noro 253:
! 254: case 2:
! 255: ac = argc(arg);
! 256: if ( !ac || ( ac > 2 ) ) {
! 257: fprintf(stderr,"argument mismatch in %s()\n",NAME(f));
! 258: error("");
! 259: }
! 260: if ( ac == 1 )
! 261: opt = 0;
! 262: else
! 263: opt = QTOS((Q)ARG1(arg));
! 264: ltop = avma;
! 265: ritopa((Obj)ARG0(arg),&a);
! 266: dmy = (GEN (*)())f->f.binf;
! 267: v = (*dmy)(a,opt);
! 268: lbot = avma;
! 269: patori(v,(Obj *)&r); gerepile(ltop,lbot,0);
! 270: return r;
! 271:
1.1 noro 272: default:
273: error("evalparif : not implemented yet.");
274: }
275: }
276:
277: struct pariftab {
278: char *name;
279: GEN (*f)();
280: int type;
281: };
282:
1.8 ! noro 283: /*
! 284: * type = 1 => argc = 1, second arg = precision
! 285: * type = 2 => argc = 1, second arg = optional (long int)
! 286: *
! 287: */
! 288:
1.1 noro 289: struct pariftab pariftab[] = {
290: {"abs",(GEN (*)())gabs,1},
291: {"adj",adj,1},
292: {"arg",garg,1},
293: {"bigomega",gbigomega,1},
294: {"binary",binaire,1},
295: {"ceil",gceil,1},
296: {"centerlift",centerlift,1},
297: {"cf",gcf,1},
298: {"classno",classno,1},
299: {"classno2",classno2,1},
300: {"conj",gconj,1},
301: {"content",content,1},
302: {"denom",denom,1},
303: {"det",det,1},
304: {"det2",det2,1},
305: {"dilog",dilog,1},
306: {"disc",discsr,1},
307: {"discf",discf,1},
308: {"divisors",divisors,1},
309: {"eigen",eigen,1},
310: {"eintg1",eint1,1},
311: {"erfc",gerfc,1},
312: {"eta",eta,1},
313: {"floor",gfloor,1},
314: {"frac",gfrac,1},
315: {"galois",galois,1},
316: {"galoisconj",galoisconj,1},
317: {"gamh",ggamd,1},
318: {"gamma",ggamma,1},
319: {"hclassno",classno3,1},
320: {"hermite",hnf,1},
321: {"hess",hess,1},
322: {"imag",gimag,1},
323: {"image",image,1},
324: {"image2",image2,1},
325: {"indexrank",indexrank,1},
326: {"indsort",indexsort,1},
327: {"initalg",initalg,1},
328: {"isfund",gisfundamental,1},
329: {"isprime",gisprime,1},
330: {"ispsp",gispsp,1},
331: {"isqrt",racine,1},
332: {"issqfree",gissquarefree,1},
333: {"issquare",gcarreparfait,1},
334: {"jacobi",jacobi,1},
335: {"jell",jell,1},
336: {"ker",ker,1},
337: {"keri",keri,1},
338: {"kerint",kerint,1},
339: {"kerintg1",kerint1,1},
340: {"kerint2",kerint2,1},
341: {"length",(GEN(*)())glength,1},
342: {"lexsort",lexsort,1},
343: {"lift",lift,1},
344: {"lindep",lindep,1},
345: {"lll",lll,1},
346: {"lllg1",lll1,1},
347: {"lllgen",lllgen,1},
348: {"lllgram",lllgram,1},
349: {"lllgramg1",lllgram1,1},
350: {"lllgramgen",lllgramgen,1},
351: {"lllgramint",lllgramint,1},
352: {"lllgramkerim",lllgramkerim,1},
353: {"lllgramkerimgen",lllgramkerimgen,1},
354: {"lllint",lllint,1},
355: {"lllkerim",lllkerim,1},
356: {"lllkerimgen",lllkerimgen,1},
357: {"lllrat",lllrat,1},
358: {"lngamma",glngamma,1},
359: {"logagm",glogagm,1},
360: {"mat",gtomat,1},
361: {"matrixqz2",matrixqz2,1},
362: {"matrixqz3",matrixqz3,1},
363: {"matsize",matsize,1},
364: {"modreverse",polymodrecip,1},
365: {"mu",gmu,1},
366: {"nextprime",nextprime,1},
367: {"norm",gnorm,1},
368: {"norml2",gnorml2,1},
369: {"numdiv",numbdiv,1},
370: {"numer",numer,1},
371: {"omega",gomega,1},
372: {"order",order,1},
373: {"ordred",ordred,1},
374: {"phi",phi,1},
375: {"pnqn",pnqn,1},
376: {"polred",polred,1},
377: {"polred2",polred2,1},
378: {"primroot",gener,1},
379: {"psi",gpsi,1},
380: {"quadgen",quadgen ,1},
381: {"quadpoly",quadpoly ,1},
382: {"real",greal,1},
383: {"recip",polrecip ,1},
384: {"redreal",redreal ,1},
385: {"regula",regula ,1},
386: {"reorder",reorder ,1},
387: {"reverse",recip ,1},
388: {"rhoreal",rhoreal ,1},
389: {"roots",roots,1},
390: {"round",ground,1},
391: {"sigma",sumdiv,1},
392: {"signat",signat,1},
393: {"simplify",simplify,1},
394: {"smalldiscf",smalldiscf,1},
395: {"smallfact",smallfact,1},
396: {"smallpolred",smallpolred,1},
397: {"smallpolred2",smallpolred2,1},
398: {"smith",smith,1},
399: {"smith2",smith2,1},
400: {"sort",sort,1},
401: {"sqr",gsqr,1},
402: {"sqred",sqred,1},
403: {"sqrt",gsqrt,1},
404: {"supplement",suppl,1},
405: {"trace",gtrace,1},
406: {"trans",gtrans,1},
407: {"trunc",gtrunc,1},
408: {"unit",fundunit,1},
409: {"vec",gtovec,1},
410: {"wf",wf,1},
411: {"wf2",wf2,1},
412: {"zeta",gzeta,1},
1.8 ! noro 413: {"factorint",factorint,2},
1.1 noro 414: {0,0,0},
415: };
416:
417: void parif_init() {
418: int i;
419:
420: for ( i = 0, parif = 0; pariftab[i].name; i++ )
421: appendparif(&parif,pariftab[i].name, (int (*)())pariftab[i].f,pariftab[i].type);
422: }
423: #else /* PARI */
424:
425: struct ftab pari_tab[] = {
426: {0,0,0},
427: };
428:
429: void parif_init() {}
430:
1.2 noro 431: pointer evalparif(f,arg)
432: FUNC f;
433: NODE arg;
434: {
1.1 noro 435: error("evalparif : PARI is not combined.");
436: }
437: #endif /*PARI */
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to parif.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin