![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b1nuC.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bint|
Return to b1nuC.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bint |
1.1 root 1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
2:
3: /*
4: $Header: b1nuC.c,v 1.4 85/08/22 16:50:36 timo Exp $
5: */
6:
7: #include <ctype.h>
8: #include "b.h"
9: #include "b0con.h"
10: #include "b0fea.h"
11: #include "b1obj.h"
12: #include "b1mem.h"
13: #include "b1num.h"
14: #include "b2syn.h" /* temporary until numconst is fixed */
15:
16: char *sprintf(); /* OS */
17: extern value tento();
18: extern integer int_tento();
19:
20: #define EXPDIGITS 10 /* Extra positions to allow for exponent part */
21: /* -- must be larger than tenlogBASE */
22: #define MAXDIGITS (MAXNUMDIG-1) /* Max precision for fixed/floating numbers */
23: #define CONVBUFSIZE (MAXDIGITS+4)
24: /* Maximum number of digits to print in integer notation */
25: /* (4 is the size of 'e+00' added by sprintf) */
26:
27:
28: /* Convert an integer to a C character string.
29: The character string is overwritten on each next call.
30: It assumes BASE is a power of 10. */
31:
32: Hidden char *convint(v) register integer v; {
33: static char *buffer, shortbuffer[tenlogBASE+3];
34: static char fmt[10];
35: register char *cp;
36: register int i;
37: bool neg = No;
38:
39: if (IsSmallInt(v)) {
40: sprintf(shortbuffer, "%d", SmallIntVal(v));
41: return shortbuffer;
42: }
43:
44: if (Digit(v, Length(v)-1) < 0) {
45: neg = Yes;
46: v = int_neg(v);
47: }
48: if (buffer) freemem(buffer);
49: buffer = getmem((unsigned)(Length(v)*tenlogBASE + 1 + neg));
50: cp = buffer;
51: if (neg) *cp++ = '-';
52: sprintf(cp, "%d", Msd(v));
53: if (!IsSmallInt(v)) {
54: if (!*fmt) sprintf(fmt, "%%0%dd", tenlogBASE);
55: while (*cp) ++cp;
56: for (i = Length(v)-2; i >= 0; --i, cp += tenlogBASE)
57: sprintf(cp, fmt, Digit(v, i));
58: if (neg) release((value) v);
59: }
60: return buffer;
61: }
62:
63: #ifdef EXT_RANGE
64:
65: /* This is terrible. But never mind, it'll all change (sometimes). */
66:
67: Hidden bool hugenumber(v) value v; {
68: bool huge;
69: real w = (real) approximate(v);
70: huge = Expo(w) > Maxexpo || Expo(w) < Minexpo && Frac(w) != 0;
71: release((value)w);
72: return huge;
73: }
74:
75:
76: Hidden string convapp(v) value v; {
77: value absv, tenlogv, expo, tentoexpo, frac;
78: static char buf[100];
79: char fmt[15];
80: int precision;
81: double fracval, expoval, i;
82:
83: absv = absval(v);
84: tenlogv = log2((value)int_10, absv), release(absv);
85: expo = floorf(tenlogv), release(tenlogv);
86: expoval = numval(expo), release(expo);
87: if (expoval*tenlogBASE >= Maxintlet || expoval*tenlogBASE <= -Maxintlet) {
88: expo = (value) mk_approx(expoval, 0.0);
89: tentoexpo = power((value)int_10, expo), release(expo);
90: }
91: else
92: tentoexpo = tento((int)expoval);
93: frac = quot(v, tentoexpo), release(tentoexpo);
94: fracval = numval(frac), release(frac);
95: while (fabs(fracval) >= 10) fracval /= 10, ++expoval;
96: while (fabs(fracval) < 1) fracval *= 10, --expoval;
97: precision = MAXDIGITS;
98: i = expoval < 0 ? -expoval : expoval;
99: while (i >= 10 && precision > 2) --precision, i /= 10;
100: /* Loose precision for large exponents! */
101: /* :-( But keep some too! )-: */
102: sprintf(fmt, "%%.%dlgE%%s%%2.0lf", precision);
103: sprintf(buf, fmt, fracval, expoval >= 0 ? "+" : "", expoval);
104: return buf;
105: }
106:
107: #endif EXT_RANGE
108:
109: /* Convert a numeric value to a C character string.
110: The character string is overwritten on each next call. */
111:
112: Visible string convnum(v) register value v; {
113: static char convbuf[3+CONVBUFSIZE+EXPDIGITS];
114: /* 3 extra for things (sign, 0.) to be stuck on front of it */
115: static char fmt[10];
116: char *bufstart = convbuf+3;
117: register char *cp = bufstart;
118: double x;
119:
120: if (Integral(v)) return convint((integer)v);
121: #ifdef EXT_RANGE
122: if (hugenumber(v)) return convapp(v);
123: #endif
124:
125: /* Reasonably-sized reals and rationals are treated alike.
126: However, not-too-large rationals resulting from
127: 'n round x' are transformed to f-format. */
128:
129: x = numval(v);
130: if (!*fmt) sprintf(fmt, "%%.%dlg", MAXDIGITS);
131: sprintf(bufstart, fmt, x);
132:
133: for (cp = bufstart; *cp != '\0'; ++cp)
134: if (*cp == 'e') { /* change sprintf's 'e' to 'E' */
135: *cp = 'E';
136: break;
137: }
138:
139: #ifdef IBMPC
140: if (*cp != 'E') {
141: /* Delete trailing zeros after decimal pt; don't rely on %g */
142: for (cp = bufstart; *cp != '\0' && *cp != '.'; ++cp)
143: ;
144: if (*cp == '.') {
145: char *ep;
146: for (; *cp != '\0' && *cp != 'E'; ++cp)
147: ;
148: ep = cp;
149: while (*--cp == '0')
150: ;
151: if (++cp < ep) {
152: while (*ep != '\0')
153: *cp++ = *ep++;
154: *cp = '\0';
155: }
156: }
157: }
158: #endif IBMPC
159:
160: if (Rational(v) && Roundsize(v) > 0 && *cp != 'E') {
161: int i = Roundsize(v);
162: int j = 1;
163: /* Counts digits allowed beyond MAXDIGITS, 1 for '.' */
164:
165: for (cp = bufstart; *cp == '0'; ++cp)
166: ++j; /* Allow a trailing zero for each leading zero */
167:
168: for (; *cp != '\0' && *cp != '.'; ++cp)
169: ; /* Find '.' or end of string */
170:
171: if (*cp == '\0') {
172: *cp = '.'; /* Append '.' if not found */
173: *++cp = '\0';
174: }
175: else {
176: while (*++cp == '0')
177: /* Allow more precision if leading zeros */
178: ++j, --i;
179: while (*cp != '\0')
180: --i, ++cp; /* Find last digit */
181: }
182:
183: /* Append extra zeros (but don't show more precision
184: than sprintf can!) */
185: while (--i >= 0 && cp < bufstart+MAXDIGITS+j)
186: *cp++ = '0';
187:
188: *cp = '\0'; /* Append new terminating null byte */
189: }
190:
191: return bufstart;
192: }
193:
194:
195: /* Convert a string to a number (assume it's syntactically correct!).
196: Pointers to the first and last+1 characters are given.
197: Again, BASE must be a power of 10.
198: ********** NEW **********
199: If E_EXACT is defined, all numbers input are made exact, even if
200: E-notation is used.
201: ********** WARNING **********
202: This routine must be fixed, because it accesses the source buffer
203: and it shouldn't because it's in the wrong place in the hierarchy
204: */
205:
206: Visible value numconst(text, end) register txptr text, end; {
207: register txptr tp;
208: register int numdigs, fraclen;
209: integer a;
210: register digit accu;
211: value c;
212:
213: if (Char(text) == 'E') a = int_1;
214: else {
215: while (text<end && Char(text)=='0') ++text; /* Skip leading zeros */
216:
217: for (tp = text; tp<end && isdigit(Char(tp)); ++tp)
218: ; /* Count integral digits */
219: numdigs = tp-text;
220: fraclen = 0;
221: if (tp<end && Char(tp)=='.') {
222: ++tp;
223: for (; tp<end && isdigit(Char(tp)); ++tp)
224: ++fraclen; /* Count fractional digits */
225: numdigs += fraclen;
226: }
227: a = (integer) grab_num((numdigs+tenlogBASE-1) / tenlogBASE);
228: if (!a) return Vnil; /* Recovered error */
229: accu = 0;
230: /* Integer part: */
231: for (; text<end && isdigit(Char(text)); ++text) {
232: accu = accu*10 + Char(text)-'0';
233: --numdigs;
234: if (numdigs%tenlogBASE == 0) {
235: Digit(a, numdigs/tenlogBASE) = accu;
236: accu = 0;
237: }
238: }
239: /* Fraction: */
240: if (text < end && Char(text) == '.') {
241: ++text;
242: for (; text<end && isdigit(Char(text)); ++text) {
243: accu = accu*10 + Char(text)-'0';
244: --numdigs;
245: if (numdigs%tenlogBASE == 0) {
246: Digit(a, numdigs/tenlogBASE) = accu;
247: accu = 0;
248: }
249: }
250: }
251: if (numdigs != 0) syserr(MESS(800, "numconst: can't happen"));
252: a = int_canon(a);
253: }
254:
255: /* Exponent: */
256: if (text >= end || Char(text) != 'E') {
257: integer b = int_tento(fraclen);
258: c = mk_exact(a, b, fraclen);
259: release((value) b);
260: }
261: else {
262: double expo = 0;
263: int sign = 1;
264: value b;
265: ++text;
266: if (text < end) {
267: if (Char(text) == '+') ++text;
268: else if (Char(text) == '-') {
269: ++text;
270: sign = -1;
271: }
272: }
273: for (; text<end && isdigit(Char(text)); ++text) {
274: expo = expo*10 + Char(text)-'0';
275: if (expo > Maxint) {
276: error(MESS(801, "excessive exponent in E-notation"));
277: expo = 0;
278: break;
279: }
280: }
281: b = tento((int)expo * sign - fraclen);
282: #ifndef E_EXACT
283: /* Make approximate number if E-notation used */
284: c = approximate(b);
285: release(b);
286: b = c;
287: #endif
288: if (a == int_1) c = b;
289: else c = prod((value)a, b), release(b);
290: }
291: release((value) a);
292: return c;
293: }
294:
295:
296: /*
297: * printnum(f, v) writes a number v on file f in such a way that it
298: * can be read back identically, assuming integral powers of ~2 can be
299: * computed exactly. (This is necessary for the permanent environment.)
300: */
301:
302: Visible Procedure printnum(f, v) FILE *f; value v; {
303: if (Approximate(v)) {
304: #ifdef PRINT_APPROX
305: if (Frac((real)v) == 0) fprintf(f, "~0");
306: else {
307: static char fmt[25];
308: if (!*fmt)
309: sprintf(fmt, "%%.%dlgE0*~2**%%.0lf", MAXDIGITS+2);
310: fprintf(f, fmt, Frac((real)v), Expo((real)v));
311: }
312: return;
313: #else
314: fputc('~', f);
315: #endif
316: }
317: if (Rational(v) && Denominator((rational)v) != int_1) {
318: int i = Roundsize(v);
319: fputs(convnum((value)Numerator((rational)v)), f);
320: if (i > 0 && i <= MAXDIGITS) {
321: /* The assumption here is that in u/v, the Roundsize
322: of the result is the sum of that of the operands. */
323: putc('.', f);
324: do putc('0', f); while (--i > 0);
325: }
326: putc('/', f);
327: v = (value) Denominator((rational)v);
328: }
329: fputs(convnum(v), f);
330: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.