Annotation of OpenXM_contrib2/asir2000/engine/real.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/engine/real.c,v 1.2 2000/02/04 09:27:31 noro Exp $
! 49: */
1.1 noro 50: #include "ca.h"
51: #include "base.h"
52: #include <math.h>
53:
54: #if defined(THINK_C)
55: double RatnToReal(a)
56: Q a;
57: {
58: double nm,dn,t;
59: int enm,edn;
60: char buf[BUFSIZ];
61:
62: nm = NatToReal(NM(a),&enm);
63: if ( INT(a) )
64: if ( enm >= 1 )
65: error("RatnToReal : Overflow");
66: else
67: return SGN(a)>0 ? nm : -nm;
68: else {
69: dn = NatToReal(DN(a),&edn);
70: sprintf(buf,"1.0E%d",enm-edn);
71: sscanf(buf,"%lf",&t);
72: if ( SGN(a) < 0 )
73: t = -t;
74: return nm/dn*t;
75: }
76: }
77:
78: double NatToReal(a,expo)
79: N a;
80: int *expo;
81: {
82: int *p;
83: int l,all,i,j,s,tb,top,tail;
84: unsigned int t,m[2];
85:
86: p = BD(a); l = PL(a) - 1;
87: for ( top = 0, t = p[l]; t; t >>= 1, top++ );
88: all = top + BSH*l; tail = (53-top)%BSH; i = l-(53-top)/BSH-1;
89: m[1] = i < 0 ? 0 : p[i]>>(BSH-tail);
90: for ( j = 1, i++, tb = tail; i <= l; i++ ) {
91: s = 32-tb; t = i < 0 ? 0 : p[i];
92: if ( BSH > s ) {
93: m[j] |= ((t&((1<<s)-1))<<tb);
94: if ( !j )
95: break;
96: else {
97: j--; m[j] = t>>s; tb = BSH-s;
98: }
99: } else {
100: m[j] |= (t<<tb); tb += BSH;
101: }
102: }
103: s = (all-1)+1023;
104: m[0] = (m[0]&((1<<20)-1))|(MIN(2046,s)<<20); *expo = MAX(s-2046,0);
105: #ifdef vax
106: t = m[0]; m[0] = m[1]; m[1] = t; itod(m);
107: #endif
108: #if defined(MIPSEL)
109: t = m[0]; m[0] = m[1]; m[1] = t;
110: #endif
111: return (double)(*((short double *)m));
112: }
113: #else
114: double RatnToReal(a)
115: Q a;
116: {
117: double nm,dn,t,man;
118: int enm,edn,e;
119: unsigned int *p,s;
120:
121: nm = NatToReal(NM(a),&enm);
122: if ( INT(a) )
123: if ( enm >= 1 )
124: error("RatnToReal : Overflow");
125: else
126: return SGN(a)>0 ? nm : -nm;
127: else {
128: dn = NatToReal(DN(a),&edn);
129: man = nm/dn;
130: if ( SGN(a) < 0 )
131: man = -man;
132: if ( ((e = enm - edn) >= 1024) || (e <= -1023) )
133: error("RatnToReal : Overflow"); /* XXX */
134: else if ( !e )
135: return man;
136: else
137: return man*pow(2,e);
138: }
139: }
140:
141: double NatToReal(a,expo)
142: N a;
143: int *expo;
144: {
145: unsigned int *p;
146: int l,all,i,j,s,tb,top,tail;
147: unsigned int t,m[2];
148:
149: p = BD(a); l = PL(a) - 1;
150: for ( top = 0, t = p[l]; t; t >>= 1, top++ );
151: all = top + BSH*l; tail = (53-top)%BSH; i = l-(53-top)/BSH-1;
152: m[1] = i < 0 ? 0 : p[i]>>(BSH-tail);
153: for ( j = 1, i++, tb = tail; i <= l; i++ ) {
154: s = 32-tb; t = i < 0 ? 0 : p[i];
155: if ( BSH > s ) {
156: m[j] |= ((t&((1<<s)-1))<<tb);
157: if ( !j )
158: break;
159: else {
160: j--; m[j] = t>>s; tb = BSH-s;
161: }
162: } else {
163: m[j] |= (t<<tb); tb += BSH;
164: }
165: }
166: s = (all-1)+1023;
167: m[0] = (m[0]&((1<<20)-1))|(MIN(2046,s)<<20); *expo = MAX(s-2046,0);
168: #ifdef vax
169: t = m[0]; m[0] = m[1]; m[1] = t; itod(m);
170: #endif
1.2 noro 171: #if defined(__i386__) || defined(MIPSEL) || defined(VISUAL) || defined(__alpha) || defined(__FreeBSD__) || defined(__NetBSD__)
1.1 noro 172: t = m[0]; m[0] = m[1]; m[1] = t;
173: #endif
174: return *((double *)m);
175: }
176: #endif
177:
178: void addreal(a,b,c)
179: Num a,b;
180: Real *c;
181: {
182: double t;
183:
184: t = ToReal(a)+ToReal(b); MKReal(t,*c);
185: }
186:
187: void subreal(a,b,c)
188: Num a,b;
189: Real *c;
190: {
191: double t;
192:
193: t = ToReal(a)-ToReal(b); MKReal(t,*c);
194: }
195:
196: void mulreal(a,b,c)
197: Num a,b;
198: Real *c;
199: {
200: double t;
201:
202: if ( !a || !b )
203: *c = 0;
204: else {
205: t = ToReal(a)*ToReal(b);
206: if ( !t )
207: error("mulreal : Underflow"); /* XXX */
208: else
209: MKReal(t,*c);
210: }
211: }
212:
213: void divreal(a,b,c)
214: Num a,b;
215: Real *c;
216: {
217: double t;
218:
219: if ( !a )
220: *c = 0;
221: else {
222: t = ToReal(a)/ToReal(b);
223: if ( !t )
224: error("divreal : Underflow"); /* XXX */
225: else
226: MKReal(t,*c);
227: }
228: }
229:
230: void chsgnreal(a,c)
231: Num a,*c;
232: {
233: double t;
234: Real s;
235:
236: if ( !a )
237: *c = 0;
238: else if ( NID(a) == N_Q )
239: chsgnq((Q)a,(Q *)c);
240: else {
241: t = -ToReal(a); MKReal(t,s); *c = (Num)s;
242: }
243: }
244:
245: void pwrreal(a,b,c)
246: Num a,b;
247: Real *c;
248: {
249: double t;
250: double pwrreal0();
251:
252: if ( !b )
253: MKReal(1.0,*c);
254: else if ( !a )
255: *c = 0;
256: else if ( !RATN(b) || !INT(b) || (PL(NM((Q)b)) > 1) ) {
257: t = (double)pow((double)ToReal(a),(double)ToReal(b));
258: if ( !t )
259: error("pwrreal : Underflow"); /* XXX */
260: else
261: MKReal(t,*c);
262: } else {
263: t = pwrreal0(BDY((Real)a),BD(NM((Q)b))[0]);
264: t = SGN((Q)b)>0?t:1/t;
265: if ( !t )
266: error("pwrreal : Underflow"); /* XXX */
267: else
268: MKReal(t,*c);
269: }
270: }
271:
272: double pwrreal0(n,e)
273: double n;
274: int e;
275: {
276: double t;
277:
278: if ( e == 1 )
279: return n;
280: else {
281: t = pwrreal0(n,e / 2);
282: return e%2 ? t*t*n : t*t;
283: }
284: }
285:
286: int cmpreal(a,b)
287: Real a,b;
288: {
289: double t;
290:
291: t = ToReal(a)-ToReal(b);
292: return t>0.0 ? 1 : t<0.0?-1 : 0;
293: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to real.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / engine