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