Annotation of OpenXM_contrib2/asir2000/builtin/bfaux.c, Revision 1.1
1.1 ! noro 1: /* $OpenXM$ */
! 2: #include "ca.h"
! 3: #include "parse.h"
! 4:
! 5: void Peval(), Psetprec(), Ptodouble();
! 6:
! 7: struct ftab bf_tab[] = {
! 8: {"eval",Peval,-2},
! 9: {"setprec",Psetprec,-1},
! 10: {"todouble",Ptodouble,1},
! 11: {0,0,0},
! 12: };
! 13:
! 14: void Ptodouble(NODE arg,Num *rp)
! 15: {
! 16: double r,i;
! 17: Real real,imag;
! 18: Num num;
! 19:
! 20: asir_assert(ARG0(arg),O_N,"todouble");
! 21: num = (Num)ARG0(arg);
! 22: if ( !num ) {
! 23: *rp = 0;
! 24: return;
! 25: }
! 26: switch ( NID(num) ) {
! 27: case N_R: case N_Q: case N_B:
! 28: r = ToReal(num);
! 29: MKReal(r,real);
! 30: *rp = (Num)real;
! 31: break;
! 32: case N_C:
! 33: r = ToReal(((C)num)->r);
! 34: i = ToReal(((C)num)->i);
! 35: MKReal(r,real);
! 36: MKReal(i,imag);
! 37: reimtocplx((Num)real,(Num)imag,rp);
! 38: break;
! 39: default:
! 40: *rp = num;
! 41: break;
! 42: }
! 43: }
! 44:
! 45: void Peval(arg,rp)
! 46: NODE arg;
! 47: Obj *rp;
! 48: {
! 49: int prec;
! 50:
! 51: asir_assert(ARG0(arg),O_R,"eval");
! 52: if ( argc(arg) == 2 ) {
! 53: prec = QTOS((Q)ARG1(arg));
! 54: if ( prec < MPFR_PREC_MIN ) prec = MPFR_PREC_MIN;
! 55: else if ( prec > MPFR_PREC_MAX ) prec = MPFR_PREC_MAX;
! 56: } else
! 57: prec = 0;
! 58: evalr(CO,(Obj)ARG0(arg),0,rp);
! 59: }
! 60:
! 61: /* bit precision */
! 62:
! 63: void Psetprec(NODE arg,Obj *rp)
! 64: {
! 65: int p;
! 66: Q q;
! 67:
! 68: long prec = mpfr_get_default_prec();
! 69:
! 70: STOQ(prec,q); *rp = (Obj)q;
! 71: if ( arg ) {
! 72: asir_assert(ARG0(arg),O_N,"setprec");
! 73: p = QTOS((Q)ARG0(arg));
! 74: if ( p > 0 )
! 75: prec = p;
! 76: }
! 77: if ( prec < MPFR_PREC_MIN ) prec = MPFR_PREC_MIN;
! 78: else if ( prec > MPFR_PREC_MAX ) prec = MPFR_PREC_MAX;
! 79: mpfr_set_default_prec(prec);
! 80: }
! 81:
! 82: Num tobf(Num a,int prec);
! 83:
! 84: void mp_pi(NODE arg,BF *rp)
! 85: {
! 86: int prec;
! 87: BF r;
! 88:
! 89: prec = arg ? QTOS((Q)ARG0(arg)) : 0;
! 90: NEWBF(r);
! 91: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 92: mpfr_const_pi(r->body,MPFR_RNDN);
! 93: *rp = r;
! 94: }
! 95:
! 96: void mp_e(NODE arg,BF *rp)
! 97: {
! 98: int prec;
! 99: mpfr_t one;
! 100: BF r;
! 101:
! 102: prec = arg ? QTOS((Q)ARG0(arg)) : 0;
! 103: NEWBF(r);
! 104: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 105: mpfr_init(one);
! 106: mpfr_set_ui(one,1,MPFR_RNDN);
! 107: mpfr_exp(r->body,one,MPFR_RNDN);
! 108: *rp = r;
! 109: }
! 110:
! 111: void mp_sin(NODE arg,BF *rp)
! 112: {
! 113: Num a;
! 114: int prec;
! 115: BF r;
! 116:
! 117: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 118: a = tobf(ARG0(arg),prec);
! 119: NEWBF(r);
! 120: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 121: mpfr_sin(r->body,((BF)a)->body,MPFR_RNDN);
! 122: *rp = r;
! 123: }
! 124:
! 125: void mp_cos(NODE arg,BF *rp)
! 126: {
! 127: Num a;
! 128: int prec;
! 129: BF r;
! 130:
! 131: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 132: a = tobf(ARG0(arg),prec);
! 133: NEWBF(r);
! 134: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 135: mpfr_cos(r->body,((BF)a)->body,MPFR_RNDN);
! 136: *rp = r;
! 137: }
! 138:
! 139: void mp_tan(NODE arg,BF *rp)
! 140: {
! 141: Num a;
! 142: int prec;
! 143: BF r;
! 144:
! 145: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 146: a = tobf(ARG0(arg),prec);
! 147: NEWBF(r);
! 148: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 149: mpfr_tan(r->body,((BF)a)->body,MPFR_RNDN);
! 150: *rp = r;
! 151: }
! 152:
! 153: void mp_asin(NODE arg,BF *rp)
! 154: {
! 155: Num a;
! 156: int prec;
! 157: BF r;
! 158:
! 159: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 160: a = tobf(ARG0(arg),prec);
! 161: NEWBF(r);
! 162: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 163: mpfr_asin(r->body,((BF)a)->body,MPFR_RNDN);
! 164: *rp = r;
! 165: }
! 166: void mp_acos(NODE arg,BF *rp)
! 167: {
! 168: Num a;
! 169: int prec;
! 170: BF r;
! 171:
! 172: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 173: a = tobf(ARG0(arg),prec);
! 174: NEWBF(r);
! 175: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 176: mpfr_acos(r->body,((BF)a)->body,MPFR_RNDN);
! 177: *rp = r;
! 178: }
! 179: void mp_atan(NODE arg,BF *rp)
! 180: {
! 181: Num a;
! 182: int prec;
! 183: BF r;
! 184:
! 185: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 186: a = tobf(ARG0(arg),prec);
! 187: NEWBF(r);
! 188: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 189: mpfr_atan(r->body,((BF)a)->body,MPFR_RNDN);
! 190: *rp = r;
! 191: }
! 192:
! 193: void mp_sinh(NODE arg,BF *rp)
! 194: {
! 195: Num a;
! 196: int prec;
! 197: BF r;
! 198:
! 199: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 200: a = tobf(ARG0(arg),prec);
! 201: NEWBF(r);
! 202: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 203: mpfr_sinh(r->body,((BF)a)->body,MPFR_RNDN);
! 204: *rp = r;
! 205: }
! 206:
! 207: void mp_cosh(NODE arg,BF *rp)
! 208: {
! 209: Num a;
! 210: int prec;
! 211: BF r;
! 212:
! 213: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 214: a = tobf(ARG0(arg),prec);
! 215: NEWBF(r);
! 216: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 217: mpfr_cosh(r->body,((BF)a)->body,MPFR_RNDN);
! 218: *rp = r;
! 219: }
! 220:
! 221: void mp_tanh(NODE arg,BF *rp)
! 222: {
! 223: Num a;
! 224: int prec;
! 225: BF r;
! 226:
! 227: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 228: a = tobf(ARG0(arg),prec);
! 229: NEWBF(r);
! 230: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 231: mpfr_tanh(r->body,((BF)a)->body,MPFR_RNDN);
! 232: *rp = r;
! 233: }
! 234:
! 235: void mp_asinh(NODE arg,BF *rp)
! 236: {
! 237: Num a;
! 238: int prec;
! 239: BF r;
! 240:
! 241: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 242: a = tobf(ARG0(arg),prec);
! 243: NEWBF(r);
! 244: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 245: mpfr_asinh(r->body,((BF)a)->body,MPFR_RNDN);
! 246: *rp = r;
! 247: }
! 248: void mp_acosh(NODE arg,BF *rp)
! 249: {
! 250: Num a;
! 251: int prec;
! 252: BF r;
! 253:
! 254: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 255: a = tobf(ARG0(arg),prec);
! 256: NEWBF(r);
! 257: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 258: mpfr_acosh(r->body,((BF)a)->body,MPFR_RNDN);
! 259: *rp = r;
! 260: }
! 261: void mp_atanh(NODE arg,BF *rp)
! 262: {
! 263: Num a;
! 264: int prec;
! 265: BF r;
! 266:
! 267: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 268: a = tobf(ARG0(arg),prec);
! 269: NEWBF(r);
! 270: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 271: mpfr_atanh(r->body,((BF)a)->body,MPFR_RNDN);
! 272: *rp = r;
! 273: }
! 274:
! 275: void mp_exp(NODE arg,BF *rp)
! 276: {
! 277: Num a;
! 278: int prec;
! 279: BF r;
! 280:
! 281: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 282: a = tobf(ARG0(arg),prec);
! 283: NEWBF(r);
! 284: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 285: mpfr_exp(r->body,((BF)a)->body,MPFR_RNDN);
! 286: *rp = r;
! 287: }
! 288:
! 289: void mp_log(NODE arg,BF *rp)
! 290: {
! 291: Num a;
! 292: int prec;
! 293: BF r;
! 294:
! 295: prec = NEXT(arg) ? QTOS((Q)ARG1(arg)) : 0;
! 296: a = tobf(ARG0(arg),prec);
! 297: NEWBF(r);
! 298: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 299: mpfr_log(r->body,((BF)a)->body,MPFR_RNDN);
! 300: *rp = r;
! 301: }
! 302:
! 303: void mp_pow(NODE arg,BF *rp)
! 304: {
! 305: Num a,e;
! 306: int prec;
! 307: BF r;
! 308:
! 309: prec = NEXT(NEXT(arg)) ? QTOS((Q)ARG2(arg)) : 0;
! 310: a = tobf(ARG0(arg),prec);
! 311: e = tobf(ARG1(arg),prec);
! 312: NEWBF(r);
! 313: prec ? mpfr_init2(r->body,prec) : mpfr_init(r->body);
! 314: mpfr_pow(r->body,((BF)a)->body,((BF)e)->body,MPFR_RNDN);
! 315: *rp = r;
! 316: }
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