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