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