Annotation of freem/src/operator.c, revision 1.11
1.1 snw 1: /*
1.11 ! snw 2: * $Id: operator.c,v 1.10 2025/05/05 23:02:39 snw Exp $
1.1 snw 3: * operators pattern-match, divide, multiply, add, power
4: *
5: *
1.4 snw 6: * Author: Serena Willis <snw@coherent-logic.com>
1.1 snw 7: * Copyright (C) 1998 MUG Deutschland
1.5 snw 8: * Copyright (C) 2020, 2025 Coherent Logic Development LLC
1.1 snw 9: *
10: *
11: * This file is part of FreeM.
12: *
13: * FreeM is free software: you can redistribute it and/or modify
14: * it under the terms of the GNU Affero Public License as published by
15: * the Free Software Foundation, either version 3 of the License, or
16: * (at your option) any later version.
17: *
18: * FreeM is distributed in the hope that it will be useful,
19: * but WITHOUT ANY WARRANTY; without even the implied warranty of
20: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21: * GNU Affero Public License for more details.
22: *
23: * You should have received a copy of the GNU Affero Public License
24: * along with FreeM. If not, see <https://www.gnu.org/licenses/>.
25: *
1.6 snw 26: * $Log: operator.c,v $
1.11 ! snw 27: * Revision 1.10 2025/05/05 23:02:39 snw
! 28: * More fixes around E notation
! 29: *
1.10 snw 30: * Revision 1.9 2025/05/05 22:52:32 snw
31: * Make E notation error message more appropriate
32: *
1.9 snw 33: * Revision 1.8 2025/05/05 19:34:46 snw
34: * Fix E notation code to disallow more than one minus sign after the E
35: *
1.8 snw 36: * Revision 1.7 2025/04/10 01:24:38 snw
37: * Remove C++ style comments
38: *
1.7 snw 39: * Revision 1.6 2025/04/09 19:52:02 snw
40: * Eliminate as many warnings as possible while building with -Wall
41: *
1.6 snw 42: * Revision 1.5 2025/03/09 19:50:47 snw
43: * Second phase of REUSE compliance and header reformat
44: *
1.5 snw 45: *
46: * SPDX-FileCopyrightText: (C) 2025 Coherent Logic Development LLC
47: * SPDX-License-Identifier: AGPL-3.0-or-later
1.1 snw 48: **/
49:
50: #include "mpsdef.h"
51: #include <stdlib.h>
52: #include <math.h>
1.10 snw 53: #include <ctype.h>
1.1 snw 54:
55: int unit (char *str);
56: extern void cond_round (char *a, int digits); /* defined in expr.c */
57:
58:
59:
60: #define PLUS '+'
61: #define MINUS '-'
62: #define POINT '.'
63: #define point (POINT-ZERO)
64: #define ZERO '0'
65: #define ONE (ZERO+1)
66: #define TWO (ZERO+2)
67: #define THREE (ZERO+3)
68: #define FIVE (ZERO+(NUMBASE/2))
69: #define NINE (ZERO+NUMBASE-1)
70: #define NUMBASE 10
71:
72: short int
1.2 snw 73: pattern (char *a, char *b) /* evaluates a ? b */
1.1 snw 74: {
75: short levels; /* depth of stack */
76: register int patx; /* match stack pointer */
77: short notpatclass; /* pattern class negation */
78: char *ptrpcd[PATDEPTH], /* pointers to patcode */
79: *position[PATDEPTH]; /* position of matching substring */
80: short mincnt[PATDEPTH], /* minimum number of matches */
81: maxcnt[PATDEPTH], /* maximum number of matches */
82: actcnt[PATDEPTH]; /* actual count of matches */
83: short Pflag,
84: Pchar; /* status in pattern alternation */
85: short altc; /* alternation counter */
86: short altcnt[PATDEPTH]; /* gr.pat.alternation counters */
87:
88: unsigned char gpmin[PATDEPTH][PATDEPTH][255]; /* grouped pattern minimum lengthes */
89: char *gp_position[PATDEPTH][PATDEPTH]; /* grouped patt.pos.of substr */
90:
91: char *ptrtom; /* pointer to match code */
92: char patcode;
93: int ch;
94: int i;
95:
96: pattrnflag = Pflag = FALSE; /* incomplete match flag */
97: pattrnchar = Pchar = EOL; /* incomplete match supplement */
98: notpatclass = FALSE; /* pattern class negation */
99: patx = 0;
100: while (*b != EOL) { /* get minimum repeat count */
101: mincnt[patx] = 0;
102: maxcnt[patx] = 255;
103: altcnt[patx] = (-1);
104: if (*b != '.') {
105: ch = (*b++) - '0';
106: while (*b >= '0' && *b <= '9') {
107: ch *= 10;
108: ch += (*b++) - '0';
109: }
110: mincnt[patx] = ch;
111: if (*b != '.')
112: maxcnt[patx] = ch;
113: }
114: /* get maximum repeat count */
115: if (*b == '.') {
116: b++;
117: if (*b >= '0' && *b <= '9') {
118: ch = (*b++) - '0';
119: while (*b >= '0' && *b <= '9') {
120: ch *= 10;
121: ch += (*b++) - '0';
122: }
123: maxcnt[patx] = ch;
124: }
125: }
126: if (maxcnt[patx] < mincnt[patx])
127: return '2'; /* just impossible! */
128: ptrpcd[patx] = b;
129: actcnt[patx] = 0;
130: position[patx] = 0;
131: /* scan strlit, ignore it when empty */
132: if (*b == '"' || *b == 'z' || (*b == '\'' && *(b + 1) == '"')) {
133: if (*(++b) == DELIM) {
134: b++;
135: continue;
136: }
137: while (*(++b) != DELIM) ;
138: b++;
139: } else if (*b == '(') {
140: i = 1;
141: b++;
142: while ((ch = *b) != EOL) {
143: b++;
144: if (ch == '"') {
145: while (*(++b) != DELIM) ;
146: }
147: if (ch == '(') {
148: i++;
149: continue;
150: }
151: if (ch == ')') {
152: i--;
153: if (i < 1)
154: break;
155: }
156: }
157: } else
158: while (*(++b) >= 'A') ;
159: if (++patx >= (PATDEPTH - 1))
160: return '3'; /* stack overflow */
161: }
162: levels = patx;
163: if (*(b - 1) == 'e' && mincnt[levels - 1] == 0 && maxcnt[levels - 1] == 255)
164: *(b - 1) = '~'; /* frequent special case: last pattern is '.E' */
165: mincnt[levels] = maxcnt[levels] = 1; /* sentinel, does never match */
166: actcnt[levels] = 0;
167: ptrpcd[levels] = b; /* (*b==EOL) */
168: patx = 0;
169: while (patx <= levels) {
170: while (actcnt[patx] < mincnt[patx]) {
171: actcnt[patx]++;
172: if (*a == EOL) {
173: pattrnflag = TRUE; /* incomplete match flag */
174: if (patx >= levels) {
175: pattrnchar = EOL;
176: return '1';
177: }
178: if (patx > 0) {
179: if (actcnt[patx - 1] != maxcnt[patx - 1])
180: return '0';
181: /* after alternation we are not sure about */
182: /* that supplement character */
183: if (*(ptrpcd[patx - 1]) == '(') {
184: pattrnchar = EOL;
185: return '0';
186: }
187: }
188: if (*(ptrpcd[patx]) == '"')
189: pattrnchar = *(ptrpcd[patx] + 1);
190: return '0';
191: }
192: for (;;)
193: {
194: /***begin section: does that char match current pattern code ***/
195: ptrtom = ptrpcd[patx];
196: ch = (*a);
197: for (;;)
198: {
199: patcode = (*ptrtom++);
200: if ((notpatclass = (patcode == '\'')))
201: patcode = (*ptrtom++);
202: switch (patcode) { /* we live in an ASCII/ISO world !! */
203: case 'c':
204: if (((ch < SP && ch >= NUL)
205: || ch == DEL) != notpatclass)
206: goto match;
207: break;
208: case 'n':
209: if ((ch <= '9' && ch >= '0') != notpatclass)
210: goto match;
211: break;
212: case 'p':
213: if (((ch >= SP && ch <= '/') ||
214: (ch >= ':' && ch <= '@') ||
215: (ch >= '[' && ch <= '`') ||
216: (ch >= '{' && ch <= '~') ||
217: (ch == '\200')) != notpatclass)
218: goto match;
219: break;
220: case 'a':
221: if (((ch >= 'A' && ch <= 'Z') ||
222: (ch >= 'a' && ch <= 'z')) != notpatclass)
223: goto match;
224: break;
225: case 'l':
226: if ((ch >= 'a' && ch <= 'z') != notpatclass)
227: goto match;
228: break;
229: case 'u':
230: if ((ch >= 'A' && ch <= 'Z') != notpatclass)
231: goto match;
232: break;
233: case 'e':
234: if (!notpatclass)
235: goto match;
236: break;
237: case '"':
238: i = 0;
239: while (a[i++] == (*ptrtom++)) ;
240: if ((*--ptrtom) == DELIM) {
241: if (notpatclass)
242: goto nomatch;
243: b = ptrpcd[patx] + 1;
244: while (*b++ != DELIM)
245: a++;
246: goto match0;
247: }
248: if (notpatclass) {
249: i--;
250: while (*ptrtom++ != DELIM) {
251: if (a[i++] == EOL)
252: goto nomatch;
253: }
254: b = ptrpcd[patx] + 2;
255: while (*b++ != DELIM)
256: a++;
257: goto match0;
258: }
259: if (a[i - 1] == EOL) {
260: pattrnflag = TRUE;
261: pattrnchar = *ptrtom;
262: }
263: goto nomatch;
264:
265: case '~':{
266: pattrnchar = EOL; /* '.E' as last pat_atom */
267: pattrnflag = TRUE;
268: return '1';
269: }
270: /* grouped pattern match */
271: case '(':{
272: char aa[256];
273: char bb[256];
274: int i1,
275: min,
276: max;
277: short pflag;
278: short pchar;
279:
280: if (Pflag) {
281: pflag = Pflag;
282: pchar = Pchar;
283: } else {
284: pflag = FALSE;
285: pchar = EOL;
286: }
287: if (altcnt[patx] < 0) {
288: for (altc = 0; altc < PATDEPTH; altc++)
289: gpmin[patx][altc][1] = 0;
290: }
291: altcnt[patx] = 0;
292: alternation:;
293: i = 0;
294: i1 = 1;
295: while (i1) {
296: bb[i] = *ptrtom++;
297: if (bb[i] == '"') {
298: while ((bb[++i] = (*ptrtom++)) != DELIM) ;
299: }
300: if (bb[i] == '(')
301: i1++;
302: if (bb[i] == ')')
303: i1--;
304: if (bb[i] == ',' && i1 == 1)
305: i1--;
306: i++;
307: }
308: bb[--i] = EOL;
309: pminmax (bb, &min, &max);
310:
311: if ((i1 = gpmin[patx][altcnt[patx]][actcnt[patx]]) < min)
312: gpmin[patx][altcnt[patx]][actcnt[patx]] = i1 = min;
313: gpmin[patx][altcnt[patx]][actcnt[patx] + 1] = 0;
314: /* too much charaters to get a match! */
315: if (i1 > max) {
316: if (*(ptrtom - 1) == ',') {
317: altcnt[patx]++;
318: goto alternation;
319: }
320: pattrnflag = pflag;
321: pattrnchar = pchar;
322: goto nomatch;
323: }
324: /* if number of chars too small, try anyway */
325: /* to get info for "incomplete" match */
326: for (i = 0; i < i1; i++)
327: if ((aa[i] = a[i]) == EOL)
328: break;
329: gp_position[patx][actcnt[patx]] = a;
330:
331: for (;;)
332: {
333: aa[i] = EOL;
334: i1 = pattern (aa, bb);
335: if (i1 == '1') {
336: gpmin[patx][altcnt[patx]][actcnt[patx]] = i;
337: a += i;
338: goto match0;
339: }
340: if (i1 != '0')
341: return i1;
342: if (pattrnflag) {
343: if (pflag == FALSE)
344: pchar = pattrnchar;
345: else if (pchar != pattrnchar)
346: pchar = EOL;
347: pflag = TRUE;
348: }
349: if (!pattrnflag) {
350: if (*(ptrtom - 1) == ',') {
351: altcnt[patx]++;
352: goto alternation;
353: }
354: pattrnflag = pflag;
355: pattrnchar = pchar;
356: goto nomatch;
357: }
358: if (a[i] == EOL) {
359: Pflag = pflag;
360: Pchar = pchar;
361: if (*(ptrtom - 1) == ',') {
362: altcnt[patx]++;
363: goto alternation;
364: }
365: pattrnflag = pflag;
366: pattrnchar = pchar;
367: return '0';
368: }
369: aa[i] = a[i];
370: i++;
371: }
372: }
373: /* match one of listed characters ?1Z"string" */
374: case 'z':
375: for (;;)
376: {
377: if ((*++ptrtom) == DELIM) {
378: if (notpatclass)
379: goto match;
380: goto nomatch;
381: }
382: if (ch != *ptrtom) {
383: if (*(ptrtom + 1) == '.' && *(ptrtom + 2) == '.') {
384: if (ch < *ptrtom ||
385: (ch > *(ptrtom + 3) && *(ptrtom + 3) != DELIM)) {
386: ptrtom += 2;
387: continue;
388: }
389: } else
390: continue;
391: }
392: while (*++ptrtom != DELIM) ;
393: if (notpatclass)
394: goto nomatch;
395: goto match;
396: }
397:
398: /* loadable matches */
399: case 'C':
400: i = 0;
401: while (zmc[i] != EOL) {
402: if (zmc[i] == ch && !notpatclass)
403: goto match;
404: i++;
405: }
406: if (notpatclass)
407: goto match;
408: break;
409: case 'N':
410: i = 0;
411: while (zmn[i] != EOL) {
412: if (zmn[i] == ch && !notpatclass)
413: goto match;
414: i++;
415: }
416: if (notpatclass)
417: goto match;
418: break;
419: case 'P':
420: i = 0;
421: while (zmp[i] != EOL) {
422: if (zmp[i] == ch && !notpatclass)
423: goto match;
424: i++;
425: }
426: if (notpatclass)
427: goto match;
428: break;
429: case 'A':
430: i = 0;
431: while (zmu[i] != EOL) {
432: if (zmu[i] == ch && !notpatclass)
433: goto match;
434: i++;
435: }
436: case 'L':
437: i = 0;
438: while (zml[i] != EOL) {
439: if (zml[i] == ch && !notpatclass)
440: goto match;
441: i++;
442: }
443: if (notpatclass)
444: goto match;
445: break;
446: case 'U':
447: i = 0;
448: while (zmu[i] != EOL) {
449: if (zmu[i] == ch && !notpatclass)
450: goto match;
451: i++;
452: }
453: if (notpatclass)
454: goto match;
455: break;
456: default:
457: goto nomatch;
458: } /* end_switch */
459: } /* end repeat */
460: /*** end section: does that char match current pattern atom ***/
461: nomatch:;
462: if (patcode == '(') {
463: for (altc = 0; altc <= altcnt[patx]; altc++)
464: gpmin[patx][altc][actcnt[patx]] = 0;
465: if (--actcnt[patx] > 0) {
466: for (altc = 0; altc <= altcnt[patx]; altc++)
467: gpmin[patx][altc][actcnt[patx]]++;
468: a = gp_position[patx][actcnt[patx]]; /* try previous patterns again */
469: continue;
470: }
471: }
472: do {
473: actcnt[patx] = 0;
474: if (--patx < 0)
475: return '0'; /* stack exhausted */
476: if (*(ptrpcd[patx]) == '(') {
477: if (actcnt[patx] >= maxcnt[patx]) {
478: ++actcnt[patx];
479: patcode = '(';
480: goto nomatch;
481: }
482: }
483: } while (++actcnt[patx] > maxcnt[patx]);
484: a = position[patx]; /* try previous patterns again */
485:
486: } /* end repeat */
487: match:;
488: a++;
489: match0:;
490: }
491: position[patx++] = a; /* pos after last match */
492: }
493: return '0';
494: } /* end of pattern */
1.2 snw 495:
1.1 snw 496: /******************************************************************************/
1.2 snw 497: void pminmax (char *str, int *min, int *max)
1.1 snw 498: {
499: int mininc,
500: maxinc,
501: i,
502: ch;
503:
504: *min = 0;
505: *max = 0;
506: mininc = 0;
507: maxinc = 0;
508: i = 0;
509: ch = 0;
510: while (str[i] != EOL) {
511: if (str[i] != '.') { /* scan minimum repeat count */
512: ch = (str[i++]) - '0';
513: while (str[i] >= '0' && str[i] <= '9') {
514: ch *= 10;
515: ch += (str[i++]) - '0';
516: }
517: mininc = ch;
518: maxinc = ch;
519: } else {
520: mininc = 0;
521: maxinc = 255;
522: }
523: if (str[i] == '.') { /* scan maximum repeat count */
524: i++;
525: if (str[i] >= '0' && str[i] <= '9') {
526: ch = (str[i++]) - '0';
527: while (str[i] >= '0' && str[i] <= '9') {
528: ch *= 10;
529: ch += (str[i]++) - '0';
530: }
531: } else
532: ch = 255;
533: maxinc = ch;
534: }
535: /* skip pattern codes */
536: if (str[i] == '"') {
537: int cnt;
538:
539: cnt = 0;
540: while (str[++i] != DELIM)
541: cnt++;
542: mininc = mininc * cnt;
543: maxinc = maxinc * cnt;
544: }
545: if (str[i] == 'z' || str[i] == '"') {
546: while (str[++i] != DELIM) ;
547: i++;
548: } else if (str[i] == '(') {
549: char tmp[256];
550: char *tcur;
551: int tmin,
552: tmax,
553: Tmin,
554: Tmax,
555: i1;
556:
557: tmin = 255;
558: tmax = 0;
559: alternation:;
560: i1 = 1;
561: tcur = tmp;
562: while (i1) {
563: ch = str[++i];
564: *tcur++ = ch;
565: if (ch == '"')
566: while ((*tcur++ = str[++i]) != DELIM) ;
567: if (ch == '(')
568: i1++;
569: if (ch == ')')
570: i1--;
571: if (ch == ',' && i1 == 1)
572: i1--;
573: }
574: *(--tcur) = EOL;
575: pminmax (tmp, &Tmin, &Tmax);
576: if (Tmin < tmin)
577: tmin = Tmin;
578: if (Tmax > tmax)
579: tmax = Tmax;
580: if (str[i] == ',')
581: goto alternation;
582: i++;
583: mininc *= tmin;
584: maxinc *= tmax;
585: } else
586: while (str[++i] >= 'A') ;
587: *min += mininc;
588: *max += maxinc;
589: }
590: if (*max > 255)
591: *max = 255;
592: return;
593: } /* end pminmax() */
594: /******************************************************************************/
1.2 snw 595: void add (char *a, char *b) /* string arithmetic a+=b; */
1.1 snw 596: {
597:
598: if (b[0] == ZERO)
599: return;
600: if (a[0] == ZERO) {
601: stcpy (a, b);
602: return;
603: } {
604: long dpa, /* decimal point of 'a' */
605: dpb, /* decimal point of 'b' */
606: lena, /* length of 'a' */
607: lenb; /* length of 'b' */
608: char mi; /* minus flag */
609: short sign; /* sign flag if a<0<b sign=-1; */
610:
611: /* if a>0>b sign=1; */
612: /* else sign=0; */
613:
614: register int i;
615: register int ch;
616: register int j;
617: register int carry;
618:
619: #if !defined(_AIX)
620: if (fp_mode) {
621: double fp_a;
622: double fp_b;
623:
624: stcnv_m2c (a);
625: stcnv_m2c (b);
626:
627: fp_a = atof (a);
628: fp_b = atof (b);
629:
630: snprintf (a, STRLEN - 1, fp_conversion, fp_a + fp_b);
631: trim_decimal (a);
632:
633: return;
634: }
635: #endif
636:
637:
638:
639: /* look at the signs */
640: mi = 0;
641: sign = 0;
642: if (a[0] == b[0] && a[0] == MINUS) {
643: mi++;
644: a[0] = b[0] = ZERO;
645: } else if (a[0] == MINUS) {
646: sign--;
647: a[0] = NINE;
648: i = 0;
649: while ((ch = a[++i]) != EOL)
650: if (ch != POINT)
651: a[i] = ZERO + NINE - ch;
652: a[--i]++;
653: } else if (b[0] == MINUS) {
654: sign++;
655: b[0] = NINE;
656: i = 0;
657: while ((ch = b[++i]) != EOL)
658: if (ch != POINT)
659: b[i] = ZERO + NINE - ch;
660: b[--i]++;
661: }
662: /* search decimal points and length */
663: dpa = dpb = (-1);
664: i = 0;
665: while (a[i] != EOL) {
666: if (a[i] == POINT)
667: dpa = i;
668: i++;
669: }
670: lena = i;
671: if (dpa < 0)
672: dpa = i;
673: again:;
674: i = 0;
675: while (b[i] != EOL) {
676: if (b[i] == POINT)
677: dpb = i;
678: i++;
679: }
680: lenb = i;
681: if (dpb < 0)
682: dpb = i;
683: if (i == 1) {
684: if (b[0] == ONE && sign == 0 && dpa > 0) { /* frequent special case: add 1 */
685: i = dpa - 1;
686: while (++a[i] > NINE) {
687: a[i--] = ZERO;
688: if (i < 0) {
689: i = lena;
690: while (i >= 0) {
691: a[i + 1] = a[i];
692: i--;
693: }
694: a[0] = ONE;
695: return;
696: }
697: }
698: return;
699: }
700: }
701: /* copy additional trailing digits from b to a */
702: if (lenb - dpb > lena - dpa) {
703: j = dpa - dpb;
704: if (lenb + j > STRLEN) { /* round off that monster ! */
705: i = STRLEN - j;
706: if (b[i] < FIVE) {
707: b[i] = EOL;
708: lenb--;
709: while (b[--i] == ZERO) {
710: b[i] = EOL;
711: lenb--;
712: }
713: } else {
714: for (;;)
715: {
716: if (i >= dpb) {
717: b[i] = EOL;
718: lenb--;
719: } else
720: b[i] = ZERO;
721: if (--i < 0) {
722: for (i = lenb; i >= 0; i--)
723: b[i + 1] = b[i];
724: b[0] = ONE;
725: dpb = ++lenb;
726: break;
727: }
728: if ((ch = b[i]) == POINT) {
729: dpb = i;
730: continue;
731: }
732: if (ch < NINE && ch >= ZERO) {
733: b[i] = ++ch;
734: break;
735: }
736: }
737: }
738: goto again; /* look what's left from b */
739: }
740: lenb = i = lena - dpa + dpb;
741: j = lena;
742: while ((a[j++] = b[i++]) != EOL) ;
743: lena = (--j);
744: b[lenb] = EOL;
745: }
746: /* $justify a or b */
747: i = dpa - dpb;
748: if (i < 0) {
749: j = lena;
750: if ((i = (lena -= i)) > (STRLEN - 2) /*was 253*/) {
751: merr_raise (M75);
752: return;
753: }
754: ch = (sign >= 0 ? ZERO : NINE);
755: while (j >= 0)
756: a[i--] = a[j--];
757: while (i >= 0)
758: a[i--] = ch;
759: dpa = dpb;
760: } else if (i > 0) {
761: j = lenb;
762: if ((lenb = (i += lenb)) > (STRLEN - 2)/*was 253*/) {
763: merr_raise (M75);
764: return;
765: }
766: ch = (sign <= 0 ? ZERO : NINE);
767: while (j >= 0)
768: b[i--] = b[j--];
769: while (i >= 0)
770: b[i--] = ch;
771: dpb = dpa;
772: }
773: /* now add */
774: carry = 0;
775: for (i = lenb - 1; i >= 0; i--) {
776: if ((ch = a[i]) == POINT)
777: continue;
778: ch += b[i] - ZERO + carry;
779: if ((carry = (ch > NINE)))
780: ch -= NUMBASE;
781: a[i] = ch;
782: }
783: while (a[lena] != EOL)
784: lena++;
785: if (carry) {
786: if ((i = (++lena)) > (STRLEN - 2)/*was 253*/) {
787: merr_raise (M75);
788: return;
789: }
790: while (i > 0) {
791: a[i] = a[i - 1];
792: i--;
793: }
794: a[0] = ONE;
795: }
796: if (sign) {
797: if (a[0] == ONE) {
798: a[0] = ZERO;
799: } else {
800: i = 0;
801: carry = 0;
802: while ((ch = a[++i]) != EOL)
803: if (ch != POINT)
804: a[i] = ZERO + NINE - ch;
805: while (--i > 0) {
806: if (a[i] != POINT) {
807: if (++a[i] <= NINE)
808: break;
809: a[i] = ZERO;
810: }
811: }
812: mi = 1;
813: a[0] = ZERO;
814: }
1.6 snw 815: while (a[(int) mi] == ZERO) {
816: stcpy (&a[(int) mi], &a[((int) mi) + 1]);
1.1 snw 817: dpa--;
818: }
819: if (dpa < 0)
820: dpa = 0;
821: }
822: /* remove trailing zeroes */
823: i = dpa;
824: while (a[i] != EOL)
825: i++;
826: if (--i > dpa) {
827: while (a[i] == ZERO)
828: a[i--] = EOL;
829: }
830: /* remove trailing point */
831: if (a[i] == POINT)
832: a[i] = EOL;
833: if (mi) {
834: if (a[0] != ZERO) {
835: i = 0;
836: while (a[i++] != EOL) ;
837: while (i > 0) {
838: a[i] = a[i - 1];
839: i--;
840: }
841: }
842: a[0] = MINUS;
843: }
1.6 snw 844: if (a[(int) mi] == EOL) {
1.1 snw 845: a[0] = ZERO;
846: a[1] = EOL;
847: }
848: return;
849: }
850: }
851: /******************************************************************************/
1.2 snw 852: void mul (char *a, char *b) /* string arithmetic a=a*b */
1.1 snw 853: {
854: char c[2*(STRLEN+1) /*was 512*/];
855: short alen,
856: blen,
857: clen,
858: mi,
859: tmpx;
860: register int acur;
861: register int bcur;
862: register int ccur;
863: register int carry;
864:
865: #if !defined(_AIX)
866: if (fp_mode) {
867: double fp_a;
868: double fp_b;
869:
870: stcnv_m2c (a);
871: stcnv_m2c (b);
872:
873: fp_a = atof (a);
874: fp_b = atof (b);
875:
876: snprintf (a, STRLEN - 1, fp_conversion, fp_a * fp_b);
877: trim_decimal (a);
878:
879: return;
880: }
881: #endif
882:
883:
884: if (merr () > OK)
885: return; /* avoid nonsense in recursion */
886: /* if zero or one there's not much to do */
887: if (b[1] == EOL) {
888: if (b[0] == ZERO) {
889: a[0] = ZERO;
890: a[1] = EOL;
891: return;
892: }
893: if (b[0] <= ONE)
894: return;
895: if (b[0] == TWO) {
896: multwo:acur = 0;
897: while (a[++acur] != EOL) ;
898: mi = (a[acur - 1] == FIVE);
899: carry = 0;
900: ccur = acur;
901: while (acur >= 0) {
902: if ((bcur = a[--acur]) < ZERO)
903: continue;
904: bcur = bcur * 2 - ZERO + carry;
905: carry = 0;
906: if (bcur > NINE) {
907: carry = 1;
908: bcur -= NUMBASE;
909: }
910: a[acur] = bcur;
911: }
912: if (carry) {
913: acur = ccur;
914: if (acur > (STRLEN - 1)/*was 254*/) {
915: merr_raise (M75);
916: return;
917: }
918: while (acur >= 0) {
919: a[acur + 1] = a[acur];
920: acur--;
921: }
922: a[a[0] == MINUS] = ONE;
923: }
924: if (mi) {
925: if (carry)
926: ccur++;
927: acur = 0;
928: while (acur < ccur)
929: if (a[acur++] == POINT) {
930: a[--ccur] = EOL;
931: if (acur == ccur)
932: a[--ccur] = EOL;
933: return;
934: }
935: }
936: return;
937: }
938: }
939: if (a[1] == EOL) {
940: if (a[0] == ZERO) {
941: return;
942: }
943: if (a[0] <= ONE) {
944: stcpy (a, b);
945: return;
946: }
947: if (a[0] == TWO) {
948: stcpy (a, b);
949: goto multwo;
950: }
951: }
952: /* get length of strings and convert ASCII to decimal */
953: /* have a look at the signs */
954: if ((mi = (a[0] == MINUS))) {
955: a[0] = ZERO;
956: }
957: if (b[0] == MINUS) {
958: b[0] = ZERO;
959: toggle (mi);
960: }
961: carry = 0;
962: alen = 0;
963: while (a[alen] != EOL) {
964: a[alen] -= ZERO;
965: if (a[alen++] == point)
966: carry = alen;
967: }
968: /* append a point on the right side if there was none */
969: if (--carry < 0) {
970: carry = alen;
971: a[alen++] = point;
972: a[alen] = 0;
973: }
974: ccur = 0;
975: blen = 0;
976: while (b[blen] != EOL) {
977: b[blen] -= ZERO;
978: if (b[blen++] == point)
979: ccur = blen;
980: }
981: if (--ccur < 0) {
982: ccur = blen;
983: b[blen++] = point;
984: b[blen] = 0;
985: }
986: carry += ccur;
987: if (carry > (STRLEN - 3) /*was 252*/) {
988: a[0] = EOL;
989: merr_raise (M75);
990: return;
991: }
992: ccur = clen = alen + blen;
993: /* init c to zero */
994: while (ccur >= 0)
995: c[ccur--] = 0;
996: c[carry] = point;
997:
998: bcur = blen;
999: clen = alen + blen - 1;
1000: carry = 0;
1001: while (bcur > 0) {
1002: if (b[--bcur] == point) {
1003: continue;
1004: }
1005: if (c[clen] == point)
1006: clen--;
1007: acur = alen;
1008: ccur = clen--;
1009: while (acur > 0) {
1010: if (a[--acur] == point)
1011: continue;
1012: if (c[--ccur] == point)
1013: --ccur;
1014: tmpx = a[acur] * b[bcur] + c[ccur] + carry;
1015: carry = tmpx / NUMBASE;
1016: c[ccur] = tmpx % NUMBASE;
1017: }
1018: while (carry) {
1019: if (c[--ccur] == point)
1020: ccur--;
1021: if ((c[ccur] += carry) >= NUMBASE) {
1022: c[ccur] -= NUMBASE;
1023: carry = 1;
1024: } else
1025: carry = 0;
1026: }
1027: }
1028: /* copy result to a and convert it */
1029: a[ccur = clen = acur = (alen += blen)] = EOL;
1030: while (--ccur >= 0) {
1031: if (c[ccur] < NUMBASE)
1032: a[ccur] = c[ccur] + ZERO;
1033: else
1034: a[alen = ccur] = POINT;
1035: }
1036: /* oversize string */
1037: if (acur > STRLEN) {
1038: if (a[acur = STRLEN] >= FIVE) {
1039: int l1;
1040:
1041: l1 = STRLEN;
1042: if (a[l1] >= FIVE) {
1043: for (;;)
1044: {
1045: if (a[--l1] == POINT)
1046: l1--;
1047: if (l1 < (a[0] == MINUS)) {
1048: for (l1 = STRLEN; l1 > 0; l1--)
1049: a[l1] = a[l1 - 1];
1050: a[a[0] == MINUS] = ONE;
1051: break;
1052: }
1053: if ((++a[l1]) == (NINE + 1))
1054: a[l1] = ZERO;
1055: else
1056: break;
1057: }
1058: }
1059: }
1060: a[acur] = EOL;
1061: }
1062: /* remove trailing zeroes */
1063: if (acur >= alen) {
1064: while (a[--acur] == ZERO)
1065: a[acur] = EOL;
1066: }
1067: /* remove trailing point */
1068: if (a[acur] == POINT)
1069: a[acur] = EOL;
1070: /* remove leading zeroes */
1071: while (a[mi] == ZERO) {
1072: acur = mi;
1073: while ((a[acur] = a[acur + 1]) != EOL)
1074: acur++;
1075: }
1076: if (a[0] == EOL) {
1077: a[0] = ZERO;
1078: a[1] = EOL;
1079: mi = 0;
1080: }
1081: if (mi) {
1082: if (a[0] != ZERO) {
1083: acur = clen;
1084: while (acur > 0) {
1085: a[acur] = a[acur - 1];
1086: acur--;
1087: }
1088: }
1089: a[0] = MINUS;
1090: }
1091: return;
1092: }
1093: /******************************************************************************
1094: * for a detailed description of the method for the divisions see *
1095: * donald e.knuth 'the art of computer programming' vol.2 p.257 *
1096: ******************************************************************************/
1.2 snw 1097: void mdiv (char *uu, char *v, short typ) /* divide string arithmetic */
1.1 snw 1098: {
1099: char q[STRLEN + 2 /*was 257*/]; /* quotient */
1100: char u[2*(STRLEN + 1)/*was 512*/];/* intermediate result */
1101: char vv[STRLEN +1 /*was 256*/];
1102: short d,
1103: d1,
1104: k1,
1105: m,
1106: ulen,
1107: vlen,
1108: dpu,
1109: dpv,
1110: guess,
1111: mi,
1112: plus,
1113: v1;
1114: register long int i;
1115: register int j;
1116: register int k;
1117: register int carry = 0;
1118:
1119: #if !defined(_AIX)
1120: if (fp_mode) {
1121: double fp_uu;
1122: double fp_v;
1123:
1124: stcnv_m2c (uu);
1125: stcnv_m2c (v);
1126:
1127: fp_uu = atof (uu);
1128: fp_v = atof (v);
1129:
1130: switch (typ) {
1131:
1132: case '/':
1133: snprintf (uu, STRLEN - 1, fp_conversion, fp_uu / fp_v);
1134: break;
1135:
1136: case '\\':
1137: snprintf (uu, STRLEN - 1, "%ld\201", (long) (fp_uu / fp_v));
1138: break;
1139:
1140: case '#':
1141: snprintf (uu, STRLEN - 1, "%ld\201", (((long) fp_uu) % ((long) fp_v)));
1.7 snw 1142: /*snprintf (uu, STRLEN - 1, "%ld\201", ((long) fp_uu < 0 ? (((long) fp_uu % (long) fp_v) + (long) fp_v) % (long) fp_v : (long) fp_uu % (long) fp_v)); */
1.1 snw 1143: break;
1144: }
1145:
1146: trim_decimal (uu);
1147:
1148: return;
1149: }
1150: #endif
1151:
1152:
1153: if (merr () > OK)
1154: return; /* avoid nonsense in recursion */
1155: if (uu[0] == ZERO)
1156: return;
1157: #ifdef NEVER
1158: /* should be faster on DIV 2, but causes some error
1159: * in connection with SQRT */
1160: if (v[1] == EOL && typ == '/') {
1161: if (v[0] == ONE)
1162: return;
1163: if (v[0] == TWO) {
1164: carry = 0;
1165: k = (-1);
1166: k1 = (-1);
1167: while ((i = uu[++k]) != EOL) {
1168: if (i < ZERO) {
1169: if (i == POINT) {
1170: k1 = k;
1171: if (k + zprecise < STRLEN)
1172: uu[k + zprecise] = EOL;
1173: }
1174: continue;
1175: }
1176: if (i == EOL)
1177: break;
1178: if (i & 01)
1179: j = NUMBASE;
1180: i = (i + ZERO + carry) / 2;
1181: carry = j;
1182: j = 0;
1183: uu[k] = i;
1184: }
1185: j = (uu[0] == MINUS);
1186: if (uu[j] == ZERO) {
1187: while (j < k) {
1188: uu[j] = uu[j + 1];
1189: j++;
1190: }
1191: k--;
1192: }
1193: if (carry && k < (STRLEN - 2) /*was 253*/) {
1194: if (k1 < 0) {
1195: k1 = k;
1196: uu[k++] = POINT;
1197: }
1198: uu[k++] = FIVE;
1199: uu[k] = EOL;
1200: }
1201: return;
1202: }
1203: }
1204: #endif /* NEVER */
1205: /* look at the signs */
1206: stcpy (u, uu);
1207: mi = 0;
1208: plus = 0;
1209: if (typ != '#') {
1210: if (u[0] == MINUS) {
1211: u[0] = ZERO;
1212: mi = 1;
1213: }
1214: if (v[0] == MINUS) {
1215: v[0] = ZERO;
1216: toggle (mi);
1217: }
1218: } else {
1219: stcpy (vv, v);
1220: if (u[0] == MINUS) {
1221: u[0] = ZERO;
1222: plus = 1;
1223: }
1224: if (v[0] == MINUS) {
1225: v[0] = ZERO;
1226: mi = 1;
1227: toggle (plus);
1228: }
1229: }
1230: /* convert from ASCII to 'number' */
1231: i = 0;
1232: dpv = (-1);
1233: k = 0;
1234: while ((j = v[i]) != EOL) {
1235: j -= ZERO;
1236: if (j == point)
1237: dpv = i;
1238: if (j == 0)
1239: k++;
1240: v[i++] = j;
1241: }
1242:
1243: v[vlen = i] = 0;
1244: v[i + 1] = 0;
1245: v[i + 2] = 0;
1246: if (v[0] != 0) {
1247: while (i >= 0) {
1248: v[i + 1] = v[i];
1249: i--;
1250: }
1251: v[0] = 0;
1252: dpv++;
1253: } else {
1254: vlen--;
1255: }
1256: d1 = 0;
1257:
1258: i = 0;
1259: dpu = (-1);
1260: while (u[i] != EOL) {
1261: u[i] -= ZERO;
1262: if (u[i] == point)
1263: dpu = i;
1264: i++;
1265: }
1266: if (dpu < 0) {
1267: u[dpu = i++] = point;
1268: }
1269: /* u[ulen=i]=0; u[i+1]=0; u[i+2]=0; */
1270: ulen = i;
1271: while (i < 512)
1272: u[i++] = 0;
1273: i = ulen; /* somehow that's necessary - sometimes I check why */
1274: if (u[0] != 0) {
1275: while (i >= 0) {
1276: u[i + 1] = u[i];
1277: i--;
1278: }
1279: u[0] = 0;
1280: dpu++;
1281: } else {
1282: ulen--;
1283: }
1284: if ((vlen + zprecise) > STRLEN && (dpv + zprecise) < vlen)
1285: vlen -= zprecise;
1286:
1287: if (dpv > 0) { /* make v an integer *//* shift v */
1288: d1 = vlen - dpv;
1289: for (i = dpv; i < vlen; i++)
1290: v[i] = v[i + 1];
1291: vlen--;
1292: /* remove leading zeroes */
1293: while (v[1] == 0) {
1294: for (i = 1; i <= vlen; i++)
1295: v[i] = v[i + 1];
1296: vlen--;
1297: }
1298: v[vlen + 1] = 0;
1299: v[vlen + 2] = 0;
1300: /* shift u */
1301: i = dpu;
1302: for (j = 0; j < d1; j++) {
1303: if (i >= ulen) {
1304: u[i + 1] = 0;
1305: ulen++;
1306: }
1307: u[i] = u[i + 1];
1308: i++;
1309: }
1310: u[i] = point;
1311: dpu = i;
1312: }
1313: d = dpu + 1 - ulen;
1314: if (dpv > dpu)
1315: d += dpv - dpu;
1316: if (typ == '/')
1317: d += zprecise;
1318: if ((d + ulen) > STRLEN) {
1319: u[0] = EOL;
1320: merr_raise (M75);
1321: return;
1322: }
1323: while (d > 0) {
1324: u[++ulen] = 0;
1325: d--;
1326: }
1327: /* normalize */
1328: if ((d = NUMBASE / (v[1] + 1)) > 1) {
1329: i = ulen;
1330: carry = 0;
1331: while (i > 0) {
1332: if (u[i] != point) {
1333: carry += u[i] * d;
1334: u[i] = carry % NUMBASE;
1335: carry = carry / NUMBASE;
1336: }
1337: i--;
1338: }
1339: u[0] = carry;
1340: i = vlen;
1341: carry = 0;
1342: while (i > 0) {
1343: carry += v[i] * d;
1344: v[i] = carry % NUMBASE;
1345: carry = carry / NUMBASE;
1346: i--;
1347: }
1348: v[0] = carry;
1349: }
1350: /* initialize */
1351: j = 0;
1352: m = ulen - vlen + 1;
1353: if (m <= dpu)
1354: m = dpu + 1;
1355: for (i = 0; i <= m; q[i++] = ZERO) ;
1356: if (typ == '#') {
1357: m = dpu - vlen;
1358: }
1359: v1 = v[1];
1360:
1361: while (j < m) {
1362: if (u[j] != point) { /* calculate guess */
1363: if ((k = u[j] * NUMBASE + (u[j + 1] == point ? u[j + 2] : u[j + 1])) == 0) {
1364: j++;
1365: continue;
1366: }
1367: k1 = (u[j + 1] == point || u[j + 2] == point ? u[j + 3] : u[j + 2]);
1368: guess = (u[j] == v1 ? (NUMBASE - 1) : k / v1);
1369: if (v[2] * guess > (k - guess * v1) * NUMBASE + k1) {
1370: guess--;
1371: if (v[2] * guess > (k - guess * v1) * NUMBASE + k1)
1372: guess--;
1373: }
1374: /* multiply and subtract */
1375: i = vlen;
1376: carry = 0;
1377: k = j + i;
1378: if (j < dpu && k >= dpu)
1379: k++;
1380: while (k >= 0) {
1381: if (u[k] == point)
1382: k--;
1383: if (i >= 0) {
1384: u[k] -= v[i--] * guess + carry;
1385: } else {
1386: if (carry == 0)
1387: break;
1388: u[k] -= carry;
1389: }
1390: carry = 0;
1391: while (u[k] < 0) {
1392: u[k] += NUMBASE;
1393: carry++;
1394: }
1395: k--;
1396: }
1397: /* test remainder / add back */
1398: if (carry) {
1399: guess--;
1400: i = vlen;
1401: carry = 0;
1402: k = j + i;
1403: if (j < dpu && k >= dpu)
1404: k++;
1405: while (k >= 0) {
1406: if (u[k] == point)
1407: k--;
1408: if (i >= 0) {
1409: u[k] += v[i--] + carry;
1410: } else {
1411: if (carry == 0)
1412: break;
1413: u[k] += carry;
1414: }
1415: carry = u[k] / NUMBASE;
1416: u[k] = u[k] % NUMBASE;
1417: k--;
1418: }
1419: }
1420: q[j++] = guess + ZERO;
1421: u[0] = 0;
1422: } else {
1423: q[j++] = POINT;
1424: }
1425: }
1426: /* unnormalize */
1427: if (typ != '#') {
1428: i = 0;
1429: while (i <= m) {
1430: if ((u[i] = q[i]) == POINT)
1431: dpv = i;
1432: i++;
1433: }
1434: k = vlen;
1435: k1 = dpv;
1436: while (k-- > 0) {
1437: while (k1 <= 0) {
1438: for (i = (++m); i > 0; i--)
1439: u[i] = u[i - 1];
1440: k1++;
1441: u[0] = ZERO;
1442: }
1443: u[k1] = u[k1 - 1];
1444: u[--k1] = POINT;
1445: dpv = k1;
1446: }
1447: u[m] = EOL;
1448: /* rounding */
1449:
1450: if (typ != '/')
1451: u[dpv + 1] = EOL;
1452: else {
1453: k = dpv + zprecise;
1454: k1 = u[k + 1] >= FIVE;
1455: u[k + 1] = EOL;
1456: if (k1) {
1457: do {
1458: if (u[k] != POINT) {
1459: if ((carry = (u[k] == NINE)))
1460: u[k] = ZERO;
1461: else
1462: u[k]++;
1463: }
1464: k--;
1465: } while (carry);
1466: }
1467: }
1468: } else { /* return the remainder */
1469: carry = 0;
1470: if (d > 1) {
1471: for (i = 0; i <= ulen; i++) {
1472: if (u[i] == point) {
1473: u[i] = POINT;
1474: dpu = i;
1475: } else {
1476: u[i] = (j = carry + u[i]) / d + ZERO;
1477: carry = j % d * NUMBASE;
1478: }
1479: }
1480: } else {
1481: for (i = 0; i <= ulen; i++)
1482: if (u[i] == point)
1483: u[dpu = i] = POINT;
1484: else
1485: u[i] += ZERO;
1486: }
1487: u[i] = EOL;
1488: if (d1 > 0) {
1489: u[i + 1] = EOL;
1490: u[i + 2] = EOL;
1491: i = dpu;
1492: for (j = 0; j < d1; j++) {
1493: u[i] = u[i - 1];
1494: i--;
1495: }
1496: u[i] = POINT;
1497: }
1498: }
1499: /* remove trailing zeroes */
1500: i = 0;
1501: k = (-1);
1502: while (u[i] != EOL) {
1503: if (u[i] == POINT)
1504: k = i;
1505: i++;
1506: }
1507: i--;
1508: if (k >= 0) {
1509: while (u[i] == ZERO && i > k)
1510: u[i--] = EOL;
1511: }
1512: /* remove trailing point */
1513: if (u[i] == POINT)
1514: u[i] = EOL;
1515: /* remove leading zeroes */
1516: while (u[0] == ZERO) {
1517: i = 0;
1518: while ((u[i] = u[i + 1]) != EOL)
1519: i++;
1520: }
1521: if (u[0] == EOL) {
1522: u[0] = ZERO;
1523: u[1] = EOL;
1524: mi = 0;
1525: }
1526: if ((mi || plus) && (u[0] != ZERO)) {
1527: if (mi != plus) {
1528: i = stlen (u) + 1;
1529: do {
1530: u[i] = u[i - 1];
1531: i--;
1532: } while (i > 0);
1533: u[0] = MINUS;
1534: }
1535: if (plus)
1536: add (u, vv);
1537: }
1538: stcpy (uu, u);
1539: return;
1540: } /* end div() */
1541: /******************************************************************************/
1.2 snw 1542: void power (char *a, char *b) /* raise a to the b-th power */
1.1 snw 1543: {
1544: char c[STRLEN + 2/*was 257*/];
1545: char d[4*(STRLEN + 1)/*was 1024*/];/* 257 should be sufficient, but somewhere there */
1546:
1547: /* is a memory leak resulting in wrong results */
1548: /* with fractional powers, e.g. 2**(3/7) */
1549: /* even a value of 513 is too small */
1550: char e[STRLEN + 2/*was 257*/];
1551: register long i;
1552: register long j;
1553:
1554: #if !defined(_AIX)
1555: if (fp_mode) {
1556: double fp_a;
1557: double fp_b;
1558:
1559: stcnv_m2c (a);
1560: stcnv_m2c (b);
1561:
1562: fp_a = atof (a);
1563: fp_b = atof (b);
1564:
1565: snprintf (a, STRLEN - 1, fp_conversion, pow (fp_a, fp_b));
1566:
1567: trim_decimal (a);
1568:
1569: return;
1570: }
1571: #endif
1572:
1573:
1574: if (merr () > OK)
1575: return; /* avoid nonsense in recursion */
1576: /* if zero or one there's not much to do */
1577: if (a[1] == EOL) {
1578: if (a[0] == ZERO) {
1579: if (b[1] == EOL && b[0] == ZERO)
1580: merr_raise (M9);
1581: return;
1582: } /* undef */
1583: if (a[0] == ONE)
1584: return;
1585: }
1586: if (b[0] == MINUS) {
1587: power (a, &b[1]);
1588: if (merr () == M75) {
1589: a[0] = ZERO;
1590: a[1] = EOL;
1591: merr_raise (OK);
1592: return;
1593: }
1594: stcpy (c, a);
1595: a[0] = ONE;
1596: a[1] = EOL;
1597: mdiv (a, c, '/');
1598: return;
1599: }
1600: if (b[1] == EOL) {
1601: switch (b[0]) {
1602: case ZERO:
1603: a[0] = ONE;
1604: a[1] = EOL;
1605: case ONE:
1606: return;
1607: case TWO:
1608: stcpy (c, a);
1609: mul (a, c);
1610: return;
1611: }
1612: }
1613: /* look for decimal point */
1614: e[0] = EOL;
1615: i = 0;
1616: while (b[i] != EOL) {
1617: if (b[i] == POINT) {
1618: if (a[0] == MINUS) {
1619: merr_raise (M9);
1620: return;
1621: } /* undefined case */
1622: if (b[i + 1] == FIVE && b[i + 2] == EOL) { /* half-integer: extra solution */
1623: if (i) {
1624: stcpy (c, b);
1625: add (b, c);
1626: power (a, b);
1627: if (merr () > OK) {
1628: a[0] = ONE;
1629: a[1] = EOL;
1630: return;
1631: }
1632: }
1633: g_sqrt (a);
1634: return;
1635: }
1636: stcpy (e, &b[i]);
1637: b[i] = EOL;
1638: break;
1639: }
1640: i++;
1641: }
1642: stcpy (d, a);
1643: i = intexpr (b);
1644: if (merr () == MXNUM)
1645: return;
1646: /* do it with a small number of multiplications */
1647: /* the number of multiplications is not optimum, but reasonably small */
1648: /* see donald e. knuth "The Art of Computer Programming" Vol.II p.441 */
1649: if (i == 0) {
1650: a[0] = ONE;
1651: a[1] = EOL;
1652: } else {
1653: j = 1;
1654: while (j < i) {
1655: j = j * 2;
1656: if (j < 0) {
1657: merr_raise (MXNUM);
1658: return;
1659: }
1660: }
1661: if (i != j)
1662: j = j / 2;
1663: j = j / 2;
1664: while (j) {
1665: stcpy (c, a);
1666: mul (a, c);
1667: if (i & j) {
1668: stcpy (c, d);
1669: mul (a, c);
1670: }
1671: j = j / 2;
1672: if (merr () == MXNUM)
1673: return;
1674: }
1675: if (e[0] == EOL)
1676: return;
1677: }
1678: /* non integer exponent */
1679: /* state of computation at this point: */
1680: /* d == saved value of a */
1681: /* a == d^^int(b); */
1682: /* e == frac(b); */
1683: {
1684: char Z[STRLEN + 2/*was 257*/];
1685:
1686: /* is fraction the inverse of an integer? */
1687: Z[0] = ONE;
1688: Z[1] = EOL;
1689: stcpy (c, e);
1690: mdiv (Z, c, '/');
1691: i = 0;
1692: for (;;)
1693: {
1694: if ((j = Z[i++]) == EOL) {
1695: j = intexpr (Z);
1696: break;
1697: }
1698: if (j != POINT)
1699: continue;
1700: j = intexpr (Z);
1701: if (Z[i] == NINE)
1702: j++;
1703: break;
1704: }
1705: Z[0] = ONE;
1706: Z[1] = EOL;
1707: lintstr (c, j);
1708: mdiv (Z, c, '/');
1709: /* if integer */
1710:
1711: if (stcmp (Z, e) == 0) {
1712: stcpy (Z, d);
1713: root (Z, j);
1714: if (merr () <= OK) {
1715: mul (a, Z);
1716: return;
1717: } /* on error try other method */
1718: merr_raise (OK);
1719: }
1720: Z[0] = ONE;
1721: Z[1] = EOL;
1722: zprecise += 2;
1723: for (;;)
1724: {
1725: c[0] = TWO;
1726: c[1] = EOL;
1727: mul (e, c);
1728: g_sqrt (d);
1729: if (e[0] == ONE) {
1730: e[0] = ZERO;
1731: numlit (e);
1732: stcpy (c, d);
1733: mul (Z, c);
1734: mround (Z, zprecise);
1735: }
1736: if (e[0] == ZERO)
1737: break;
1738: i = 0;
1739: j = (d[0] == ONE ? ZERO : NINE);
1740: for (;;) {
1741: ++i;
1742: if (d[i] != j && d[i] != '.')
1743: break;
1744: }
1745: if (d[i] == EOL || (i > zprecise))
1746: break;
1747: }
1748: zprecise -= 2;
1749: mul (a, Z);
1750: mround (a, zprecise + 1);
1751: }
1752: return;
1753: } /* end power() */
1754: /******************************************************************************/
1.2 snw 1755: void g_sqrt (char *a) /* square root */
1.1 snw 1756: {
1757: register int i,
1758: ch;
1759:
1760: if (a[0] == ZERO)
1761: return;
1762: if (a[0] == MINUS) {
1763: merr_raise (M9);
1764: return;
1765: }
1766: if (merr () > OK)
1767: return; /* avoid nonsense in recursion */
1768: {
1769: char tmp1[STRLEN +2 /*was 257*/],
1770: tmp2[STRLEN +2 /*was 257*/],
1771: XX[STRLEN +2 /*was 257*/],
1772: XXX[STRLEN +2 /*was 257*/];
1773:
1774: stcpy (XX, a);
1775: /* look for good initial value */
1776: if (a[0] > ONE || (a[0] == ONE && a[1] != POINT)) {
1777: i = 0;
1778: while ((ch = a[i++]) != EOL) {
1779: if (ch == POINT)
1780: break;
1781: }
1782: if ((i = (i + 1) / 2))
1783: a[i] = EOL;
1784: } else if (a[0] != ONE) {
1785: a[0] = ONE;
1786: a[1] = EOL;
1787: }
1788: /* "Newton's" algorithm with quadratic convergence */
1789: zprecise++;
1790: do {
1791: stcpy (XXX, a);
1792: stcpy (tmp1, XX);
1793: stcpy (tmp2, a);
1794: mdiv (tmp1, tmp2, '/');
1795: if (merr () > OK)
1796: break;
1797: add (a, tmp1);
1798: tmp2[0] = TWO;
1799: tmp2[1] = EOL;
1800: mdiv (a, tmp2, '/');
1801: } while (comp (a, XXX));
1802: zprecise--;
1803: return;
1804: }
1805: } /* end g_sqrt() */
1806: /******************************************************************************/
1.2 snw 1807: void root (char *a, long n) /* n.th root */
1.1 snw 1808: {
1809: register int i,
1810: ch;
1811:
1812: if (a[0] == ZERO)
1813: return;
1814: if (a[0] == MINUS || n == 0) {
1815: merr_raise (M9);
1816: return;
1817: }
1818: if (merr () > OK)
1819: return; /* avoid nonsense in recursion */
1820: {
1821: char tmp1[STRLEN +2/*was 257*/],
1822: tmp2[STRLEN +2/*was 257*/],
1823: XX[STRLEN +2/*was 257*/],
1824: XXX[STRLEN +2/*was 257*/];
1825: short again;
1826:
1827: stcpy (XX, a);
1828: /* look for good initial value */
1829: if (a[0] > ONE || (a[0] == ONE && a[1] != POINT)) {
1830: i = 0;
1831: while ((ch = a[i++]) != EOL && ch != POINT) ;
1832: if ((i = (i + n - 2) / n) > 0) {
1833: a[0] = THREE;
1834: a[i] = EOL;
1835: }
1836: } else if (a[0] != ONE) {
1837: a[0] = ONE;
1838: a[1] = EOL;
1839: }
1840: /* "Newton's" algorithm with quadratic convergence */
1841:
1842: if (zprecise <= 3)
1843: again = 0; /* speedup div with small zprec. */
1844: else {
1845: again = zprecise;
1846: zprecise = 2;
1847: }
1848: second:;
1849: zprecise++;
1850: for (;;) {
1851: stcpy (XXX, a);
1852: lintstr (tmp1, n - 1);
1853: stcpy (tmp2, a);
1854: power (tmp2, tmp1);
1855: stcpy (tmp1, XX);
1856: mdiv (tmp1, tmp2, '/');
1857: if (merr () > OK)
1858: break;
1859: lintstr (tmp2, n - 1);
1860: mul (a, tmp2);
1861: add (a, tmp1);
1862: lintstr (tmp2, n);
1863: mdiv (a, tmp2, '/');
1864: stcpy (tmp2, a);
1865: mdiv (XXX, tmp2, '/');
1866: tmp2[0] = ONE;
1867: if (zprecise <= 0)
1868: tmp2[1] = EOL;
1869: else {
1870: tmp2[1] = POINT;
1871: for (i = 2; i < zprecise; i++)
1872: tmp2[i] = ZERO;
1873: tmp2[i++] = FIVE;
1874: tmp2[i] = EOL;
1875: }
1876: if (!comp (XXX, tmp2))
1877: continue;
1878: if (zprecise <= 0)
1879: break;
1880: tmp2[0] = POINT;
1881: for (i = 1; i < zprecise; i++)
1882: tmp2[i] = NINE;
1883: tmp2[i - 1] = FIVE;
1884: tmp2[i] = EOL;
1885: if (comp (tmp2, XXX))
1886: break;
1887: }
1888: zprecise--;
1889: if (again) {
1890: zprecise = again;
1891: again = 0;
1892: goto second;
1893: }
1894: return;
1895: }
1896: } /* end root() */
1897: /******************************************************************************/
1.2 snw 1898: int numlit (char *str)
1.1 snw 1899: {
1900: long j,
1901: mi = 0,
1902: pointx = (-1),
1903: expflg = 0;
1904: long val,
1905: exp = 0L;
1906: int result;
1907: register int i = 0;
1908: register int ch;
1909:
1910: result = 0;
1911: if (str[0] < ONE) {
1912: if (str[0] == EOL) {
1913: str[0] = ZERO;
1914: str[1] = EOL;
1915: return (0);
1916: }
1917: /* compact signs */
1918: while (str[i] == PLUS || str[i] == MINUS)
1919: if (str[i++] == MINUS)
1920: mi++;
1921: if ((j = (mi &= 01)))
1922: str[0] = MINUS;
1923: /* compact leading zeroes */
1924: while (str[i] == ZERO)
1925: i++;
1926: if (i > j)
1927: stcpy (&str[j], &str[i]);
1928: if (str[mi] == EOL) {
1929: str[0] = ZERO;
1930: str[1] = EOL;
1931: return (0);
1932: }
1933: i = mi;
1934: }
1935: while ((ch = str[i]) <= NINE && ch >= ZERO)
1936: i++;
1937: if ((result = unit (&str[i]))) {
1938: if (i == mi) {
1939: str[0] = '0';
1940: i = 1;
1941: }
1942: ch = str[i] = EOL;
1943: }
1944: if (ch == EOL)
1945: return (result);
1946: if (ch == POINT) {
1947: pointx = i++;
1948: while ((ch = str[i]) <= NINE && ch >= ZERO)
1949: i++;
1950: if ((result = unit (&str[i])))
1951: ch = str[i] = EOL;
1952: if (ch == EOL) {
1953: i = pointx;
1954: goto point0;
1955: }
1956: }
1957: /* check for zero mantissa */
1958: j = 0;
1959: while (j < i) {
1960: if (str[j] > ZERO) {
1961: j = (-1);
1962: break;
1963: }
1964: j++;
1965: }
1966: if (j >= 0) {
1967: str[0] = ZERO;
1968: str[1] = EOL;
1969: return (result);
1970: }
1971: /* search for exponent */
1972: for (; ch != EOL; ch = str[++i]) {
1973: if (ch <= NINE && ch >= ZERO) {
1974: if (expflg) {
1975: ch -= ZERO;
1976: val = exp * NUMBASE + ch;
1977: /* check for numeric overflow */
1978: if (((val - ch) / NUMBASE) != exp) {
1979: merr_raise (MXNUM);
1980: return (0);
1981: }
1982: exp = val;
1983: }
1984: continue;
1985: }
1.11 ! snw 1986: if (expflg) {
1.1 snw 1987: if (ch == MINUS) {
1.11 ! snw 1988: /* TODO: revisit this; it breaks string coercion
1.10 snw 1989: if (str[i + 1] == '-') {
1990: merr_raise (INVEXPR);
1991: return (0);
1992: }
1993: if (!isdigit (str[i + 1])) {
1.9 snw 1994: merr_raise (INVEXPR);
1.8 snw 1995: return (0);
1996: }
1.11 ! snw 1997: */
1.1 snw 1998: expflg = (-expflg);
1999: continue;
2000: }
1.10 snw 2001: if (ch == PLUS) {
1.11 ! snw 2002: /* TODO: revisit this; it breaks string coercion
1.10 snw 2003: if (str[i + 1] == '+') {
2004: merr_raise (INVEXPR);
2005: return (0);
2006: }
2007: if (!isdigit (str[i + 1])) {
2008: merr_raise (INVEXPR);
2009: return (0);
2010: }
1.11 ! snw 2011: */
1.1 snw 2012: continue;
1.10 snw 2013: }
1.1 snw 2014: }
2015: if ((result = unit (&str[i])))
2016: ch = str[i] = EOL;
2017: str[i] = EOL;
2018: if (ch == 'E' || (lowerflag && ch == 'e')) {
2019: expflg++;
2020: continue;
2021: }
2022: break;
2023: }
2024: /* append a point at the right end */
2025: if (expflg) {
2026: if (pointx < 0) {
2027: i = mi;
2028: while (str[i] != EOL)
2029: i++;
2030: if (i >= (STRLEN - 1)/*was 254*/) {
2031: str[STRLEN] = EOL;
2032: merr_raise (M75);
2033: return (0);
2034: }
2035: str[pointx = i] = POINT;
2036: str[++i] = EOL;
2037: }
2038: /* if exp shift decimal point */
2039: if (expflg > 0) {
2040: while (exp-- > 0) {
2041: if ((str[pointx] = str[pointx + 1]) == EOL) {
2042: if (pointx >= (STRLEN - 1)/*was 254*/)
2043: break;
2044: str[pointx] = ZERO;
2045: str[pointx + 1] = str[pointx + 2] = EOL;
2046: }
2047: pointx++;
2048: }
2049: if (pointx >= (STRLEN - 1)/*was 254*/) {
2050: str[STRLEN] = EOL;
2051: merr_raise (M75);
2052: return (0);
2053: }
2054: str[pointx] = POINT;
2055: } else { /* (expflg<0) */
2056: while (exp-- > 0) {
2057: if (--pointx < 0) {
2058: i = pointx = 0;
2059: while (str[i++] != EOL) ;
2060: if (i >= (STRLEN - 1)/*was 254*/) {
2061: merr_raise (M75);
2062: return (0);
2063: }
2064: while (i-- > 0)
2065: str[i + 1] = str[i];
2066: str[0] = ZERO;
2067: }
2068: str[pointx + 1] = str[pointx];
2069: }
2070: str[pointx] = POINT;
2071: }
2072: }
2073: if ((i = pointx) >= 0) {
2074:
2075: point0:
2076:
2077: while (str[++i] != EOL) ;
2078:
2079: i--;
2080: while (str[i] == ZERO)
2081: str[i--] = EOL; /* remove trailing zeroes */
2082: if (str[i] == POINT)
2083: str[i] = EOL; /* remove trailing point */
2084: }
2085: if (str[mi] == EOL) {
2086: str[0] = ZERO;
2087: str[1] = EOL;
2088: }
2089: return (result);
2090: }
2091: /******************************************************************************/
2092: int unit (char *str)
2093: /**
2094: * str is interpreted as a currency
2095: * symbol
2096: * return value: 1=EUR, 4=DM, ...
2097: * 0=other */
2098:
2099: {
2100: char ch;
2101:
2102: ch = str[0];
2103: if ((ch < 'A') || (ch > 'P'))
2104: return 0;
2105: switch (ch) {
2106: case 'E':
2107: if (str[1] == 'U' && str[2] == 'R')
2108: return 1;
2109: if (str[1] == 'S' && str[2] == 'P')
2110: return 5;
2111: return 0;
2112: case 'D':
2113: if (str[1] == 'M')
2114: return 4;
2115: if (str[1] == 'E' && str[2] == 'M')
2116: return 4;
2117: return 0;
2118: case 'A':
2119: if (str[1] == 'T' && str[2] == 'S')
2120: return 2;
2121: return 0;
2122: case 'B':
2123: if (str[1] == 'F' && str[2] == 'R')
2124: return 3;
2125: return 0;
2126: case 'F':
2127: if (str[1] == 'F')
2128: return 7;
2129: if (str[1] == 'M' && str[2] == 'K')
2130: return 6;
2131: if (str[1] == 'R' && str[2] == 'F')
2132: return 7;
2133: return 0;
2134: case 'I':
2135: if (str[1] == 'E' && str[2] == 'P')
2136: return 8;
2137: if (str[1] == 'T' && str[2] == 'L')
2138: return 9;
2139: return 0;
2140: case 'N':
2141: if (str[1] == 'L' && str[2] == 'G')
2142: return 10;
2143: return 0;
2144: case 'P':
2145: if (str[1] == 'T' && str[2] == 'E')
2146: return 11;
2147: }
2148: return 0;
2149: }
2150: /******************************************************************************/
1.2 snw 2151: long intexpr (char *str)
1.1 snw 2152: {
2153: {
2154: register int ch;
2155: register int i = 0;
2156: register long value;
2157: register long newval;
2158: short minus = FALSE;
2159:
2160: if ((ch = str[0]) == MINUS) {
2161: ch = str[1];
2162: minus = TRUE;
2163: i = 1;
2164: }
2165: if (ch >= ZERO && ch <= NINE) {
2166: value = ch - ZERO;
2167: while ((ch = str[++i]) >= ZERO && ch <= NINE) {
2168: newval = value * NUMBASE;
2169: if (newval < 0 || ((newval / NUMBASE) != value)) {
2170: merr_raise (MXNUM);
2171: return (minus ? -1 : 1);
2172: };
2173: newval += ((long) ch - ZERO);
2174: if (newval < 0) {
2175: merr_raise (MXNUM);
2176: return (minus ? -1 : 1);
2177: };
2178: value = newval;
2179: }
2180: if (minus)
2181: value = (-value);
2182: if (ch == EOL)
2183: return value;
2184: } else if (ch != ZERO && ch != PLUS && ch != MINUS && ch != POINT)
2185: return 0L;
2186: }
2187: {
2188: register int ch;
2189: register int i = 0;
2190: register long value;
2191: register long newval;
2192: char tmp[STRLEN +2/*was 257*/];
2193:
2194: stcpy (tmp, str);
2195: numlit (tmp);
2196: i = (tmp[0] == MINUS);
2197: if (merr () == MXNUM)
2198: return (i ? -1 : 1);
2199: value = 0L;
2200: while ((ch = tmp[i++]) >= ZERO && ch <= NINE) {
2201: newval = value * NUMBASE;
2202: if (newval < 0 || ((newval / NUMBASE) != value)) {
2203: merr_raise (MXNUM);
2204: value = 1;
2205: break;
2206: }
2207: newval += ((long) ch - ZERO);
2208: if (newval < 0) {
2209: merr_raise (MXNUM);
2210: value = 1;
2211: break;
2212: }
2213: value = newval;
2214: }
2215: if (tmp[0] == MINUS)
2216: value = (-value);
2217: return value;
2218: }
2219: } /* end of intexpr */
2220: /******************************************************************************/
1.2 snw 2221: short int tvexpr (char *str) /* str is interpreted as truth valued expression */
1.1 snw 2222: {
2223: if (str[0] > ZERO && str[0] <= NINE) {
2224: str[0] = ONE;
2225: str[1] = EOL;
2226: return TRUE;
2227: }
2228: if (str[1] == EOL) {
2229: str[0] = ZERO;
2230: return FALSE;
2231: } {
2232: register int ch;
2233: register int i = 0;
2234: register int pointx = FALSE;
2235: register int sign = FALSE;
2236:
2237: for (;;)
2238: {
2239: if ((ch = str[i]) > ZERO && ch <= NINE) {
2240: str[0] = ONE;
2241: str[1] = EOL;
2242: return TRUE;
2243: }
2244: i++;
2245: if ((ch == PLUS || ch == MINUS) && sign == FALSE)
2246: continue;
2247: sign = TRUE;
2248: if (ch == ZERO)
2249: continue;
2250: if (ch == POINT && pointx == FALSE) {
2251: sign = TRUE;
2252: pointx = TRUE;
2253: continue;
2254: }
2255: str[0] = ZERO;
2256: str[1] = EOL;
2257: return FALSE;
2258: }
2259: }
2260: }
1.2 snw 2261:
1.1 snw 2262: /******************************************************************************/
1.2 snw 2263: void m_op (char *a, char *b, short op)
1.1 snw 2264: {
2265: int atyp,
2266: btyp; /* DM/EUR currency types */
2267: char tmp[(STRLEN + 1)/*was 256*/];
2268:
2269: switch (op & 0177) { /* binary operators */
2270: case '_':
2271: if (op & 0200)
2272: break; /* NOT_OPERAND */
2273: if (stcat (a, b) == 0) {
2274: merr_raise (M75);
2275: }
2276: return;
2277: case '=':
2278: if (stcmp (a, b))
2279: *a = ZERO;
2280: else
2281: *a = ONE;
2282: if (op & 0200)
2283: toggle (*a); /* NOT_OPERAND */
2284: a[1] = EOL;
2285: return;
2286: case '[':
2287: if (*b == EOL || find (a, b))
2288: *a = ONE;
2289: else
2290: *a = ZERO;
2291: if (op & 0200)
2292: toggle (*a); /* NOT_OPERAND */
2293: a[1] = EOL;
2294: return;
2295: case ']':
2296: if (*b == EOL) {
2297: if (*a == EOL)
2298: *a = ZERO;
2299: else
2300: *a = ONE;
2301: }
2302: /* frequent special case */
2303: else if (stcmp (a, b) <= 0)
2304: *a = ZERO;
2305: else
2306: *a = ONE;
2307: if (op & 0200)
2308: toggle (*a); /* NOT_OPERAND */
2309: a[1] = EOL;
2310: return;
2311: } /* end switch */
2312: atyp = numlit (a);
2313: if (op == '-') {
2314: stcpy (&tmp[1], b);
2315: tmp[0] = '-';
2316: op = '+';
2317: } else
2318: stcpy (tmp, b);
2319: btyp = numlit (tmp);
2320: switch (op & 0177) { /* binary operators, NOT OMITTED */
2321: case '+':
2322: if (op & 0200) {
2323: merr_raise (ASSIGNER);
2324: return;
2325: } /* NOT_OPERAND */
2326: #ifdef EUR2DEM
2327: if (atyp != btyp) {
2328: char tmp2[256];
2329:
2330: if ((atyp == 0) && (a[0] == '0'))
2331: atyp = btyp; /* zero is any currency */
2332: if ((btyp == 0) && (tmp[0] == '0'))
2333: btyp = atyp; /* zero is any currency */
2334: if (atyp && btyp) {
2335: if (atyp > 1) {
2336: stcpy (tmp2, EUR2WHR[atyp]);
2337: mul (tmp, tmp2);
2338: }
2339: if (btyp > 1) {
2340: zprecise += 4;
2341: stcpy (tmp2, EUR2WHR[btyp]);
2342: mdiv (tmp, tmp2, '/');
2343: zprecise -= 4;
2344: }
2345: } else if (atyp != btyp && typemmflag) {
2346: merr_raise (TYPEMISMATCH);
2347: return;
2348: }
2349: }
2350: #endif /* EUR2DEM */
2351: add (a, tmp);
2352: plus02:
2353: #ifdef EUR2DEM
2354: if (atyp == 0)
2355: break;
2356: if (atyp != btyp)
2357: cond_round (a, zprecise);
2358: if (atyp)
2359: stcat (a, WHR[atyp]);
2360: #endif /* EUR2DEM */
2361: break;
2362:
2363: case '*':
2364: if (op & 0200) {
2365: merr_raise (ASSIGNER);
2366: return;
2367: } /* NOT_OPERAND */
2368: #ifdef EUR2DEM
2369: if (btyp && atyp == 0) {
2370: atyp = btyp;
2371: btyp = 0;
2372: }
2373: if (atyp && btyp) {
2374: if (typemmflag) {
2375: merr_raise (TYPEMISMATCH);
2376: return;
2377: }
2378: atyp = btyp = 0;
2379: }
2380: #endif /* EUR2DEM */
2381: mul (a, tmp);
2382:
2383: #ifdef EUR2DEM
2384: if (atyp) {
2385: cond_round (a, zprecise);
2386: stcat (a, WHR[atyp]);
2387: }
2388: #endif /* EUR2DEM */
2389: break;
2390:
2391: case '/':
2392: case '\\':
2393: case '#':
2394:
2395: if (op & 0200) {
2396: merr_raise (ASSIGNER);
2397: return;
2398: } /* NOT_OPERAND */
2399: #ifdef EUR2DEM
2400: if (atyp != btyp) {
2401: char tmp2[(STRLEN + 1)/*was 256*/];
2402:
2403: if (atyp && btyp) {
2404: if (op == '#') {
2405: if (atyp > 1) {
2406: stcpy (tmp2, EUR2WHR[atyp]);
2407: mul (tmp, tmp2);
2408: }
2409: if (btyp > 1) {
2410: stcpy (tmp2, EUR2WHR[btyp]);
2411: mdiv (tmp, tmp2, '/');
2412: }
2413: } else {
2414: if (atyp > 1) {
2415: stcpy (tmp2, EUR2WHR[atyp]);
2416: mul (tmp, tmp2);
2417: }
2418: if (btyp > 1) {
2419: stcpy (tmp2, EUR2WHR[btyp]);
2420: mul (a, tmp2);
2421: }
2422: atyp = btyp = 0;
2423: }
2424: } else if (btyp && typemmflag && (*a != '0' || op == '#')) {
2425: merr_raise (TYPEMISMATCH);
2426: return;
2427: }
2428: } else if (op != '#')
2429: atyp = 0;
2430: #endif /* EUR2DEM */
2431: if (tmp[0] == ZERO) {
2432: merr_raise (M9);
2433: break;
2434: }
2435: mdiv (a, tmp, op);
2436: goto plus02;
2437:
2438: case ' ':
2439: power (a, tmp);
2440: break; /* ' ' stands for power */
2441:
2442: case '>':
2443:
2444: #ifdef EUR2DEM
2445: if (atyp != btyp) {
2446: char tmp2[(STRLEN + 1)/*was 256*/];
2447:
2448: if ((atyp == 0) && (a[0] == '0'))
2449: atyp = btyp; /* zero is any currency */
2450: if ((btyp == 0) && (tmp[0] == '0'))
2451: btyp = atyp; /* zero is any currency */
2452: if (atyp && btyp) {
2453: if (atyp > 1) {
2454: stcpy (tmp2, EUR2WHR[atyp]);
2455: mul (tmp, tmp2);
2456: }
2457: if (btyp > 1) {
2458: stcpy (tmp2, EUR2WHR[btyp]);
2459: mul (a, tmp2);
2460: }
2461: cond_round (a, zprecise + 2);
2462: cond_round (tmp, zprecise + 2);
2463: } else if (atyp != btyp && typemmflag) {
2464: merr_raise (TYPEMISMATCH);
2465: return;
2466: }
2467: }
2468: #endif /* EUR2DEM */
2469: if (comp (tmp, a))
2470: *a = ONE;
2471: else
2472: *a = ZERO;
2473: if (op & 0200)
2474: toggle (*a); /* NOT_OPERAND */
2475: a[1] = EOL;
2476: break;
2477:
2478: case '<':
2479:
2480: #ifdef EUR2DEM
2481: if (atyp != btyp) {
2482: char tmp2[(STRLEN + 1)/*was 256*/];
2483:
2484: if ((atyp == 0) && (a[0] == '0'))
2485: atyp = btyp; /* zero is any currency */
2486: if ((btyp == 0) && (tmp[0] == '0'))
2487: btyp = atyp; /* zero is any currency */
2488: if (atyp && btyp) {
2489: if (atyp > 1) {
2490: stcpy (tmp2, EUR2WHR[atyp]);
2491: mul (tmp, tmp2);
2492: }
2493: if (btyp > 1) {
2494: stcpy (tmp2, EUR2WHR[btyp]);
2495: mul (a, tmp2);
2496: }
2497: cond_round (a, zprecise + 2);
2498: cond_round (tmp, zprecise + 2);
2499: } else if (atyp != btyp && typemmflag) {
2500: merr_raise (TYPEMISMATCH);
2501: return;
2502: }
2503: }
2504: #endif /* EUR2DEM */
2505: if (comp (a, tmp))
2506: *a = ONE;
2507: else
2508: *a = ZERO;
2509: if (op & 0200)
2510: toggle (*a); /* NOT_OPERAND */
2511: a[1] = EOL;
2512: break;
2513:
2514: case '&':
2515:
2516: if (tvexpr (a)) {
2517: tvexpr (tmp);
2518: *a = *tmp;
2519: }
2520: if (op & 0200)
2521: toggle (*a); /* NOT_OPERAND */
2522: a[1] = EOL;
2523: break;
2524:
2525: case '!':
2526:
2527: if (tvexpr (a) == FALSE && tvexpr (tmp))
2528: *a = ONE;
2529: if (op & 0200)
2530: toggle (*a); /* NOT_OPERAND */
2531: a[1] = EOL;
2532: break;
2533:
2534: default:
2535: merr_raise (ASSIGNER);
2536:
2537: }
2538: return;
2539: } /* end m_op */
2540: /******************************************************************************/
2541: /* rounding */
2542: /* 'a' is assumed to be a 'canonic' numeric string */
2543: /* it is rounded to 'digits' fractional digits */
1.3 snw 2544: void mround (char *a, int digits)
1.1 snw 2545: {
2546: int ch,
2547: i,
2548: pointpos,
2549: lena;
2550:
2551: pointpos = -1;
2552: i = 0;
2553: i = 0;
2554: while (a[i] != EOL) {
2555: if (a[i] == POINT)
2556: pointpos = i;
2557: i++;
2558: }
2559: lena = i;
2560: if (pointpos < 0)
2561: pointpos = i;
2562: if ((pointpos + digits + 1) >= i)
2563: return; /* nothing to round */
2564: i = pointpos + digits + 1;
2565: if (a[i] < FIVE) {
2566: a[i] = EOL;
2567: while (a[--i] == ZERO)
2568: a[i] = EOL;
2569: if (a[i] == POINT) {
2570: a[i] = EOL;
2571: if (i == 0 || (i == 1 && a[0] == MINUS))
2572: a[0] = ZERO;
2573: }
2574: return;
2575: }
2576: for (;;)
2577: {
2578: if (i >= pointpos)
2579: a[i] = EOL;
2580: else
2581: a[i] = ZERO;
2582: if (--i < (a[0] == MINUS)) {
2583: for (i = lena; i >= 0; i--)
2584: a[i + 1] = a[i];
2585: a[a[0] == '-'] = ONE;
2586: break;
2587: }
2588: if ((ch = a[i]) == POINT)
2589: continue;
2590: if (a[i] < NINE && ch >= ZERO) {
2591: a[i] = ++ch;
2592: break;
2593: }
2594: }
2595: return;
2596: } /* end mround */
2597:
1.2 snw 2598: /* End of $Source: /home/cvsroot/freem/src/operator.c,v $ */
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to operator.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem / src