Annotation of OpenXM_contrib2/asir2000/builtin/bfaux.c, Revision 1.4
1.4 ! noro 1: /* $OpenXM: OpenXM_contrib2/asir2000/builtin/bfaux.c,v 1.3 2015/08/05 01:23:02 noro Exp $ */
1.1 noro 2: #include "ca.h"
3: #include "parse.h"
4:
1.4 ! noro 5: void Peval(), Psetprec(), Psetbprec(), Ptodouble(), Psetround();
1.1 noro 6:
7: struct ftab bf_tab[] = {
8: {"eval",Peval,-2},
9: {"setprec",Psetprec,-1},
1.3 noro 10: {"setbprec",Psetbprec,-1},
1.4 ! noro 11: {"setround",Psetround,-1},
1.1 noro 12: {"todouble",Ptodouble,1},
13: {0,0,0},
14: };
15:
1.4 ! noro 16: int mpfr_roundmode = MPFR_RNDN;
! 17:
1.1 noro 18: void Ptodouble(NODE arg,Num *rp)
19: {
20: double r,i;
21: Real real,imag;
22: Num num;
23:
24: asir_assert(ARG0(arg),O_N,"todouble");
25: num = (Num)ARG0(arg);
26: if ( !num ) {
27: *rp = 0;
28: return;
29: }
30: switch ( NID(num) ) {
31: case N_R: case N_Q: case N_B:
32: r = ToReal(num);
33: MKReal(r,real);
34: *rp = (Num)real;
35: break;
36: case N_C:
37: r = ToReal(((C)num)->r);
38: i = ToReal(((C)num)->i);
39: MKReal(r,real);
40: MKReal(i,imag);
41: reimtocplx((Num)real,(Num)imag,rp);
42: break;
43: default:
44: *rp = num;
45: break;
46: }
47: }
48:
1.4 ! noro 49: void Peval(NODE arg,Obj *rp)
1.1 noro 50: {
51: int prec;
52:
53: asir_assert(ARG0(arg),O_R,"eval");
54: if ( argc(arg) == 2 ) {
1.3 noro 55: prec = QTOS((Q)ARG1(arg))*3.32193;
1.1 noro 56: if ( prec < MPFR_PREC_MIN ) prec = MPFR_PREC_MIN;
57: else if ( prec > MPFR_PREC_MAX ) prec = MPFR_PREC_MAX;
58: } else
59: prec = 0;
1.2 noro 60: evalr(CO,(Obj)ARG0(arg),prec,rp);
1.1 noro 61: }
62:
1.3 noro 63: /* set/get decimal precision */
1.1 noro 64:
65: void Psetprec(NODE arg,Obj *rp)
66: {
67: int p;
68: Q q;
1.3 noro 69: int prec,dprec;
70:
71: prec = mpfr_get_default_prec();
72: /* decimal precision */
73: dprec = prec*0.30103;
74: STOQ(dprec,q); *rp = (Obj)q;
75: if ( arg ) {
76: asir_assert(ARG0(arg),O_N,"setprec");
77: prec = QTOS((Q)ARG0(arg))*3.32193;
78: if ( p > 0 )
79: prec = p;
80: }
81: if ( prec < MPFR_PREC_MIN ) prec = MPFR_PREC_MIN;
82: else if ( prec > MPFR_PREC_MAX ) prec = MPFR_PREC_MAX;
83: mpfr_set_default_prec(prec);
84: }
1.1 noro 85:
1.3 noro 86: /* set/get bit precision */
1.1 noro 87:
1.3 noro 88: void Psetbprec(NODE arg,Obj *rp)
89: {
90: int p;
91: Q q;
92: int prec;
93:
94: prec = mpfr_get_default_prec();
95: STOQ(prec,q); *rp = (Obj)q;
1.1 noro 96: if ( arg ) {
1.3 noro 97: asir_assert(ARG0(arg),O_N,"setbprec");
98: prec = QTOS((Q)ARG0(arg));
1.1 noro 99: if ( p > 0 )
100: prec = p;
101: }
102: if ( prec < MPFR_PREC_MIN ) prec = MPFR_PREC_MIN;
103: else if ( prec > MPFR_PREC_MAX ) prec = MPFR_PREC_MAX;
104: mpfr_set_default_prec(prec);
105: }
106:
1.4 ! noro 107: void Psetround(NODE arg,Q *rp)
! 108: {
! 109: int round;
! 110:
! 111: STOQ(mpfr_roundmode,*rp);
! 112: if ( arg ) {
! 113: asir_assert(ARG0(arg),O_N,"setround");
! 114: round = QTOS((Q)ARG0(arg));
! 115: switch ( round ) {
! 116: case 0:
! 117: mpfr_roundmode = MPFR_RNDN;
! 118: break;
! 119: case 1:
! 120: mpfr_roundmode = MPFR_RNDZ;
! 121: break;
! 122: case 2:
! 123: mpfr_roundmode = MPFR_RNDU;
! 124: break;
! 125: case 3:
! 126: mpfr_roundmode = MPFR_RNDD;
! 127: break;
! 128: case 4:
! 129: mpfr_roundmode = MPFR_RNDA;
! 130: break;
! 131: case 5:
! 132: mpfr_roundmode = MPFR_RNDF;
! 133: break;
! 134: case 6:
! 135: mpfr_roundmode = MPFR_RNDNA;
! 136: break;
! 137: default:
! 138: error("setround : invalid rounding mode");
! 139: break;
! 140: }
! 141: }
! 142: }
! 143:
1.1 noro 144: Num tobf(Num a,int prec);
145:
146: void mp_pi(NODE arg,BF *rp)
147: {
148: int prec;
149: BF r;
150:
151: prec = arg ? QTOS((Q)ARG0(arg)) : 0;
152: NEWBF(r);
153: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 154: mpfr_const_pi(r->body,mpfr_roundmode);
1.1 noro 155: *rp = r;
156: }
157:
158: void mp_e(NODE arg,BF *rp)
159: {
160: int prec;
161: mpfr_t one;
162: BF r;
163:
164: prec = arg ? QTOS((Q)ARG0(arg)) : 0;
165: NEWBF(r);
166: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
167: mpfr_init(one);
1.4 ! noro 168: mpfr_set_ui(one,1,mpfr_roundmode);
! 169: mpfr_exp(r->body,one,mpfr_roundmode);
1.1 noro 170: *rp = r;
171: }
172:
173: void mp_sin(NODE arg,BF *rp)
174: {
175: Num a;
176: int prec;
177: BF r;
178:
179: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
180: a = tobf(ARG0(arg),prec);
181: NEWBF(r);
182: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 183: mpfr_sin(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 184: *rp = r;
185: }
186:
187: void mp_cos(NODE arg,BF *rp)
188: {
189: Num a;
190: int prec;
191: BF r;
192:
193: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
194: a = tobf(ARG0(arg),prec);
195: NEWBF(r);
196: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 197: mpfr_cos(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 198: *rp = r;
199: }
200:
201: void mp_tan(NODE arg,BF *rp)
202: {
203: Num a;
204: int prec;
205: BF r;
206:
207: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
208: a = tobf(ARG0(arg),prec);
209: NEWBF(r);
210: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 211: mpfr_tan(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 212: *rp = r;
213: }
214:
215: void mp_asin(NODE arg,BF *rp)
216: {
217: Num a;
218: int prec;
219: BF r;
220:
221: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
222: a = tobf(ARG0(arg),prec);
223: NEWBF(r);
224: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 225: mpfr_asin(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 226: *rp = r;
227: }
228: void mp_acos(NODE arg,BF *rp)
229: {
230: Num a;
231: int prec;
232: BF r;
233:
234: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
235: a = tobf(ARG0(arg),prec);
236: NEWBF(r);
237: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 238: mpfr_acos(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 239: *rp = r;
240: }
241: void mp_atan(NODE arg,BF *rp)
242: {
243: Num a;
244: int prec;
245: BF r;
246:
247: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
248: a = tobf(ARG0(arg),prec);
249: NEWBF(r);
250: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 251: mpfr_atan(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 252: *rp = r;
253: }
254:
255: void mp_sinh(NODE arg,BF *rp)
256: {
257: Num a;
258: int prec;
259: BF r;
260:
261: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
262: a = tobf(ARG0(arg),prec);
263: NEWBF(r);
264: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 265: mpfr_sinh(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 266: *rp = r;
267: }
268:
269: void mp_cosh(NODE arg,BF *rp)
270: {
271: Num a;
272: int prec;
273: BF r;
274:
275: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
276: a = tobf(ARG0(arg),prec);
277: NEWBF(r);
278: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 279: mpfr_cosh(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 280: *rp = r;
281: }
282:
283: void mp_tanh(NODE arg,BF *rp)
284: {
285: Num a;
286: int prec;
287: BF r;
288:
289: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
290: a = tobf(ARG0(arg),prec);
291: NEWBF(r);
292: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 293: mpfr_tanh(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 294: *rp = r;
295: }
296:
297: void mp_asinh(NODE arg,BF *rp)
298: {
299: Num a;
300: int prec;
301: BF r;
302:
303: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
304: a = tobf(ARG0(arg),prec);
305: NEWBF(r);
306: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 307: mpfr_asinh(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 308: *rp = r;
309: }
310: void mp_acosh(NODE arg,BF *rp)
311: {
312: Num a;
313: int prec;
314: BF r;
315:
316: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
317: a = tobf(ARG0(arg),prec);
318: NEWBF(r);
319: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 320: mpfr_acosh(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 321: *rp = r;
322: }
323: void mp_atanh(NODE arg,BF *rp)
324: {
325: Num a;
326: int prec;
327: BF r;
328:
329: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
330: a = tobf(ARG0(arg),prec);
331: NEWBF(r);
332: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 333: mpfr_atanh(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 334: *rp = r;
335: }
336:
337: void mp_exp(NODE arg,BF *rp)
338: {
339: Num a;
340: int prec;
341: BF r;
342:
343: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
344: a = tobf(ARG0(arg),prec);
345: NEWBF(r);
346: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 347: mpfr_exp(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 348: *rp = r;
349: }
350:
351: void mp_log(NODE arg,BF *rp)
352: {
353: Num a;
354: int prec;
355: BF r;
356:
357: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
358: a = tobf(ARG0(arg),prec);
359: NEWBF(r);
360: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 361: mpfr_log(r->body,((BF)a)->body,mpfr_roundmode);
1.1 noro 362: *rp = r;
363: }
364:
365: void mp_pow(NODE arg,BF *rp)
366: {
367: Num a,e;
368: int prec;
369: BF r;
370:
371: prec = NEXT(NEXT(arg)) ? QTOS((Q)ARG2(arg)) : 0;
372: a = tobf(ARG0(arg),prec);
373: e = tobf(ARG1(arg),prec);
374: NEWBF(r);
375: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
1.4 ! noro 376: mpfr_pow(r->body,((BF)a)->body,((BF)e)->body,mpfr_roundmode);
1.1 noro 377: *rp = r;
378: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to bfaux.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin