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