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