fold.c
1 //! @file fold.c
2 //! @author J. Marcel van der Veer
3 //
4 //! @section Copyright
5 //
6 // This file is part of VIF - vintage FORTRAN compiler.
7 // Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
8 //
9 //! @section License
10 //
11 // This program is free software; you can redistribute it and/or modify it
12 // under the terms of the GNU General Public License as published by the
13 // Free Software Foundation; either version 3 of the License, or
14 // (at your option) any later version.
15 //
16 // This program is distributed in the hope that it will be useful, but
17 // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 // more details. You should have received a copy of the GNU General Public
20 // License along with this program. If not, see <http://www.gnu.org/licenses/>.
21
22 //! @section Synopsis
23 //!
24 //! Constant folder.
25
26 #include <vif.h>
27 #include <rts-real32.h>
28
29 // A trivial calculator to compiler generated constant expressions.
30
31 // INTEGER
32 // Exponentiation is already optimised by the code generator.
33
34 static int_4 calc_int_add (char **, int_4 *);
35
36 static int_4 calc_int_fact (char **s, int_4 *val)
37 {
38 while (isspace (*s[0])) {
39 (*s)++;
40 }
41 if (isdigit ((*s)[0])) {
42 *val = strtol (*s, s, 10);
43 return TRUE;
44 } else if ((*s)[0] == '-') {
45 int_4 rc;
46 (*s)++;
47 rc = calc_int_fact (s, val);
48 *val = -*val;
49 return rc;
50 } else if ((*s)[0] == '(') {
51 int_4 rc, sub;
52 (*s)++;
53 rc = calc_int_add (s, &sub);
54 (*s)++; // Assume ')'
55 *val = sub;
56 return rc;
57 }
58 return FALSE;
59 }
60
61 static int_4 calc_int_mul (char **s, int_4 *val)
62 {
63 int_4 lval, rval;
64 if (!calc_int_fact (s, &lval)) {
65 return FALSE;
66 }
67 while (isspace (*s[0])) {
68 (*s)++;
69 }
70 while ((*s)[0] != '\0' && ((*s)[0] == '*' || (*s)[0] == '/' || (*s[0]) == '%')) {
71 char op = (*s)++[0];
72 if (!calc_int_fact (s, &rval)) {
73 return FALSE;
74 }
75 if (op == '*') {
76 lval *= rval;
77 } else if (op == '/') {
78 lval /= rval;
79 } else {
80 lval %= rval;
81 }
82 while ((*s)[0] == ' ') {
83 (*s)++;
84 }
85 }
86 *val = lval;
87 return TRUE;
88 }
89
90 static int_4 calc_int_add (char **s, int_4 *val)
91 {
92 int_4 lval, rval;
93 if (!calc_int_mul (s, &lval)) {
94 return FALSE;
95 }
96 while ((*s)[0] == ' ') {
97 (*s)++;
98 }
99 while ((*s)[0] != '\0' && ((*s)[0] == '+' || (*s)[0] == '-')) {
100 char op = (*s)++[0];
101 if (!calc_int_mul (s, &rval)) {
102 return FALSE;
103 }
104 if (op == '+') {
105 lval += rval;
106 } else {
107 lval -= rval;
108 }
109 while (isspace (*s[0])) {
110 (*s)++;
111 }
112 }
113 *val = lval;
114 return TRUE;
115 }
116
117 int_4 calc_int_4 (char *p, int_4 *val)
118 {
119 char *q = p;
120 int_4 rc = calc_int_add (&q, val) && (q[0] == '\0');
121 return rc;
122 }
123
124 void fold_int_4 (char *buf, char *p)
125 {
126 RECORD q;
127 int_4 val;
128 bufcpy (q, p, RECLN);
129 if (calc_int_4 (q, &val)) {
130 _srecordf (buf, "%d", val);
131 } else {
132 bufcpy (buf, p, RECLN);
133 }
134 }
135
136 // REAL
137 // Exponentiation is already optimised by the code generator.
138
139 static int_4 calc_real_add (char **, real_32 *);
140
141 static int_4 calc_real_fact (char **s, real_32 *val)
142 {
143 while (isspace (*s[0])) {
144 (*s)++;
145 }
146 if (isdigit ((*s)[0])) {
147 *val = strtox (*s, s);
148 if ((*s)[0] == 'q') {
149 (*s)++;
150 }
151 return TRUE;
152 } else if ((*s)[0] == '-') {
153 int_4 rc;
154 (*s)++;
155 rc = calc_real_fact (s, val);
156 *val = xneg (*val);
157 return rc;
158 } else if ((*s)[0] == '(') {
159 int_4 rc;
160 real_32 sub;
161 (*s)++;
162 rc = calc_real_add (s, &sub);
163 (*s)++; // Assume ')'
164 *val = sub;
165 return rc;
166 }
167 return FALSE;
168 }
169
170 static int_4 calc_real_mul (char **s, real_32 *val)
171 {
172 real_32 lval, rval;
173 if (!calc_real_fact (s, &lval)) {
174 return FALSE;
175 }
176 while (isspace (*s[0])) {
177 (*s)++;
178 }
179 while ((*s)[0] != '\0' && ((*s)[0] == '*' || (*s)[0] == '/')) {
180 char op = (*s)++[0];
181 if (!calc_real_fact (s, &rval)) {
182 return FALSE;
183 }
184 if (op == '*') {
185 lval = xmul (lval, rval);
186 } else if (op == '/') {
187 if (xis0 (&rval)) {
188 ERROR (1501, "division by zero", NO_TEXT);
189 return FALSE;
190 } else {
191 lval = xdiv (lval, rval);
192 }
193 }
194 while ((*s)[0] == ' ') {
195 (*s)++;
196 }
197 }
198 *val = lval;
199 return TRUE;
200 }
201
202 static int_4 calc_real_add (char **s, real_32 *val)
203 {
204 real_32 lval, rval;
205 if (!calc_real_mul (s, &lval)) {
206 return FALSE;
207 }
208 while ((*s)[0] == ' ') {
209 (*s)++;
210 }
211 while ((*s)[0] != '\0' && ((*s)[0] == '+' || (*s)[0] == '-')) {
212 char op = (*s)++[0];
213 if (!calc_real_mul (s, &rval)) {
214 return FALSE;
215 }
216 if (op == '+') {
217 lval = xadd (lval, rval, 0);
218 } else {
219 lval = xadd (lval, rval, 1);
220 }
221 while (isspace (*s[0])) {
222 (*s)++;
223 }
224 }
225 *val = lval;
226 return TRUE;
227 }
228
229 int_4 calc_real (char *p, real_32 *val)
230 {
231 char *q = p;
232 int_4 rc = calc_real_add (&q, val) && (q[0] == '\0');
233 return rc;
234 }
235
236 // COMPLEX
237
238 static int_4 calc_complex_add (char **, complex_64 *);
239
240 int skip (char **q, char *p)
241 {
242 size_t N = strlen (p);
243 if (strncmp (*q, p, N) == 0) {
244 (*q) += N;
245 return TRUE;
246 } else {
247 return FALSE;
248 }
249 }
250
251 static int_4 calc_complex_fact (char **s, complex_64 *val)
252 {
253 while (isspace (*s[0])) {
254 (*s)++;
255 }
256 (void) skip (s, "CMPLXQ");
257 (void) skip (s, "CMPLXF");
258 (void) skip (s, "CMPLX");
259 while (isspace (*s[0])) {
260 (*s)++;
261 }
262 if (isdigit ((*s)[0])) {
263 real_32 z;
264 z = strtox (*s, s);
265 if ((*s)[0] == 'q') {
266 (*s)++;
267 }
268 *val = (complex_64) {z, X_0};
269 return TRUE;
270 } else if ((*s)[0] == '-') {
271 int_4 rc;
272 (*s)++;
273 rc = calc_complex_fact (s, val);
274 *val = cxneg (*val);
275 return rc;
276 } else if ((*s)[0] == '(') {
277 int_4 rc;
278 complex_64 sub;
279 (*s)++;
280 char *t = *s;
281 if (isdigit ((*s)[0]) || (*s)[0] == '+' || (*s)[0] == '-') {
282 real_32 re, im;
283 re = strtox (*s, s);
284 if ((*s)[0] == 'q') {
285 (*s)++;
286 }
287 if ((*s)[0] == ',') {
288 (*s)++;
289 im = strtox (*s, s);
290 if ((*s)[0] == 'q') {
291 (*s)++;
292 }
293 sub = (complex_64) {re, im};
294 rc = TRUE;
295 } else {
296 *s = t;
297 rc = calc_complex_add (s, &sub);
298 }
299 } else {
300 rc = calc_complex_add (s, &sub);
301 }
302 (*s)++; // Assume ')'
303 *val = sub;
304 return rc;
305 }
306 return FALSE;
307 }
308
309 static int_4 calc_complex_mul (char **s, complex_64 *val)
310 {
311 complex_64 lval, rval;
312 if (!calc_complex_fact (s, &lval)) {
313 return FALSE;
314 }
315 while (isspace (*s[0])) {
316 (*s)++;
317 }
318 while ((*s)[0] != '\0' && ((*s)[0] == '*' || (*s)[0] == '/')) {
319 char op = (*s)++[0];
320 if (!calc_complex_fact (s, &rval)) {
321 return FALSE;
322 }
323 if (op == '*') {
324 lval = cxmul (lval, rval);
325 } else if (op == '/') {
326 lval = cxdiv (lval, rval);
327 }
328 while ((*s)[0] == ' ') {
329 (*s)++;
330 }
331 }
332 *val = lval;
333 return TRUE;
334 }
335
336 static int_4 calc_complex_add (char **s, complex_64 *val)
337 {
338 complex_64 lval, rval;
339 if (!calc_complex_mul (s, &lval)) {
340 return FALSE;
341 }
342 while ((*s)[0] == ' ') {
343 (*s)++;
344 }
345 while ((*s)[0] != '\0' && ((*s)[0] == '+' || (*s)[0] == '-')) {
346 char op = (*s)++[0];
347 if (!calc_complex_mul (s, &rval)) {
348 return FALSE;
349 }
350 if (op == '+') {
351 lval = cxsum (lval, rval);
352 } else {
353 lval = cxsub (lval, rval);
354 }
355 while (isspace (*s[0])) {
356 (*s)++;
357 }
358 }
359 *val = lval;
360 return TRUE;
361 }
362
363 int_4 calc_complex (char *p, complex_64 *val)
364 {
365 char *q = p;
366 int_4 rc = calc_complex_add (&q, val) && (q[0] == '\0');
367 return rc;
368 }
369
370 // Drivers.
371
372 char *pretty_float (char *num)
373 {
374 // Cut zero exponent and end-zeroes in floats.
375 RECORD expo;
376 RECCLR (expo);
377 char *e = strchr (num, 'e');
378 if (e != NO_TEXT) {
379 _srecordf (expo, "%s", &e[1]);
380 *e = '\0';
381 }
382 RECORD frac;
383 RECCLR (frac);
384 char *f = strchr (num, '.');
385 if (f != NO_TEXT) {
386 _srecordf (frac, "%s", &f[1]);
387 *f = '\0';
388 }
389 // Simplify exponent.
390 if (e != NO_TEXT) {
391 int expd;
392 sscanf (expo, "%d", &expd);
393 if (expd != 0) {
394 _srecordf (expo, "%d", expd);
395 }
396 }
397 // Simplify fraction.
398 while (strlen (frac) > 0 && frac[strlen (frac) - 1] == '0') {
399 frac[strlen (frac) - 1] = '\0';
400 }
401 // Compose pretty float,
402 if (strlen (frac) > 0) {
403 strcat (num, ".");
404 strcat (num, frac);
405 } else {
406 strcat (num, ".0");
407 }
408 if (strlen (expo) > 0) {
409 strcat (num, "e");
410 strcat (num, expo);
411 }
412 return num;
413 }
414
415 void pretty_number (char *num, int_4 prec, real_32 val)
416 {
417 RECORD stre, strf, fmt;
418 _srecordf (fmt, "%%.%df", prec);
419 _fprintf_real_32 (strf, fmt, val, 5, FLT256_DIG);
420 real_32 valf = strtox (strf, NO_REF_TEXT);
421 _srecordf (fmt, "%%.%de", prec);
422 _fprintf_real_32 (stre, fmt, val, 5, FLT256_DIG);
423 real_32 vale = strtox (stre, NO_REF_TEXT);
424 if (xeq (vale, valf)) {
425 _srecordf (num, "%s", pretty_float (strf));
426 } else {
427 _srecordf (num, "%s", pretty_float (stre));
428 }
429 }
430
431 void pretty_real (char *num, int_4 prec, real_32 val)
432 {
433 switch (prec) {
434 case 4: {
435 pretty_number (num, FLT_DIG + 1, val);
436 return;
437 }
438 case 8: {
439 pretty_number (num, DBL_DIG + 1, val);
440 return;
441 }
442 case 16: {
443 pretty_number (num, FLT128_DIG + 1, val);
444 bufcat (num, "q", RECLN);
445 return;
446 }
447 case 32: {
448 pretty_number (num, FLT256_DIG, val);
449 return;
450 }
451 }
452 }
453
454 void pretty_complex (char *num, int_4 prec, complex_64 cval)
455 {
456 RECORD RE, IM;
457 switch (prec) {
458 case 8: {
459 pretty_real (RE, 4, cxre (cval));
460 pretty_real (IM, 4, cxim (cval));
461 _srecordf (num, "CMPLXF (%s, %s)", RE, IM);
462 return;
463 }
464 case 16: {
465 pretty_real (RE, 8, cxre (cval));
466 pretty_real (IM, 8, cxim (cval));
467 _srecordf (num, "CMPLX (%s, %s)", RE, IM);
468 return;
469 }
470 case 32: {
471 pretty_real (RE, 16, cxre (cval));
472 pretty_real (IM, 16, cxim (cval));
473 _srecordf (num, "CMPLXQ (%s, %s)", RE, IM);
474 return;
475 }
476 }
477 }
478
479 int_4 fold_intrinsic (INTRINS *F, EXPR *lhs, EXPR *rhs)
480 {
481 if (lhs->variant != EXPR_CONST) {
482 return FALSE;
483 } else if (!valid_expr (lhs)) {
484 return FALSE;
485 } else if (rhs != NO_EXPR && rhs->variant != EXPR_CONST) {
486 return FALSE;
487 } else if (rhs != NO_EXPR && !valid_expr (rhs)) {
488 return FALSE;
489 } else if (F->f3 != NULL && rhs == NO_EXPR) {
490 complex_64 lval;
491 if (! (accept_mode (lhs->mode.type, lhs->mode.len, COMPLEX, 32) && calc_complex (lhs->str, &lval))) {
492 return FALSE;
493 }
494 complex_64 cval = (F->f3) (lval);
495 pretty_complex (lhs->str, F->alen, cval);
496 return TRUE;
497 } else {
498 RECORD num;
499 num[0] = '\0';
500 real_32 lval;
501 if (! (accept_mode (lhs->mode.type, lhs->mode.len, REAL, 16) && calc_real (lhs->str, &lval))) {
502 return FALSE;
503 }
504 if (F->f1 != NULL) {
505 // Single-argumenters.
506 pretty_real (num, 32, (F->f1) (lval));
507 }
508 if (rhs != NO_EXPR) {
509 real_32 rval;
510 if (! (accept_mode (rhs->mode.type, rhs->mode.len, REAL, 16) && calc_real (rhs->str, &rval))) {
511 return FALSE;
512 }
513 if (F->f2 != NULL) {
514 // Two-argumenters.
515 pretty_real (num, 32, (F->f2) (lval, rval));
516 }
517 }
518 if (strlen (num) > 0) {
519 strcpy (lhs->str, num);
520 return TRUE;
521 } else {
522 return FALSE;
523 }
524 }
525 }
526
527 int_4 fold_expr (EXPR *reg, int_4 expect)
528 {
529 if (reg->variant != EXPR_CONST) {
530 return FALSE;
531 } else if (!valid_expr (reg)) {
532 return FALSE;
533 } else {
534 if ((reg->mode.type == INTEGER || (reg->mode.type == REAL && reg->mode.len <= 16))) {
535 real_32 rval;
536 if (calc_real (reg->str, &rval)) {
537 if (reg->mode.type == INTEGER || expect == INTEGER) {
538 reg->mode.type = INTEGER;
539 reg->mode.len = 4;
540 _srecordf (reg->str, "%d", _xint4 (rval));
541 } else {
542 RECORD z;
543 RECCLR (z);
544 pretty_real (z, reg->mode.len, rval);
545 strcpy (reg->str, z);
546 }
547 return TRUE;
548 } else {
549 return FALSE;
550 }
551 } else if (reg->mode.type == COMPLEX && reg->mode.len <= 32) {
552 complex_64 cval;
553 if (calc_complex (reg->str, &cval)) {
554 pretty_complex (reg->str, reg->mode.len, cval);
555 return TRUE;
556 } else {
557 return FALSE;
558 }
559 } else {
560 return FALSE;
561 }
562 }
563 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
