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 NEW_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 (1701, "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 NEW_RECORD (expo);
376 char *e = strchr (num, 'e');
377 if (e != NO_TEXT) {
378 _srecordf (expo, "%s", &e[1]);
379 *e = '\0';
380 }
381 NEW_RECORD (frac);
382 char *f = strchr (num, '.');
383 if (f != NO_TEXT) {
384 _srecordf (frac, "%s", &f[1]);
385 *f = '\0';
386 }
387 // Simplify exponent.
388 if (e != NO_TEXT) {
389 int expd;
390 sscanf (expo, "%d", &expd);
391 if (expd != 0) {
392 _srecordf (expo, "%d", expd);
393 }
394 }
395 // Simplify fraction.
396 while (strlen (frac) > 0 && frac[strlen (frac) - 1] == '0') {
397 frac[strlen (frac) - 1] = '\0';
398 }
399 // Compose pretty float,
400 if (strlen (frac) > 0) {
401 strcat (num, ".");
402 strcat (num, frac);
403 } else {
404 strcat (num, ".0");
405 }
406 if (strlen (expo) > 0) {
407 strcat (num, "e");
408 strcat (num, expo);
409 }
410 return num;
411 }
412
413 void pretty_number (char *num, int_4 prec, real_32 val)
414 {
415 NEW_RECORD (stre); NEW_RECORD (strf); NEW_RECORD (fmt);
416 _srecordf (fmt, "%%.%df", prec);
417 _fprintf_real_32 (strf, fmt, val, 5, FLT256_DIG);
418 real_32 valf = strtox (strf, NO_REF_TEXT);
419 _srecordf (fmt, "%%.%de", prec);
420 _fprintf_real_32 (stre, fmt, val, 5, FLT256_DIG);
421 real_32 vale = strtox (stre, NO_REF_TEXT);
422 if (xeq (vale, valf)) {
423 _srecordf (num, "%s", pretty_float (strf));
424 } else {
425 _srecordf (num, "%s", pretty_float (stre));
426 }
427 }
428
429 void pretty_real (char *num, int_4 prec, real_32 val)
430 {
431 switch (prec) {
432 case 4: {
433 pretty_number (num, FLT_DIG + 1, val);
434 return;
435 }
436 case 8: {
437 pretty_number (num, DBL_DIG + 1, val);
438 return;
439 }
440 case 16: {
441 pretty_number (num, FLT128_DIG + 1, val);
442 bufcat (num, "q", RECLN);
443 return;
444 }
445 case 32: {
446 pretty_number (num, FLT256_DIG, val);
447 return;
448 }
449 }
450 }
451
452 void pretty_complex (char *num, int_4 prec, complex_64 cval)
453 {
454 NEW_RECORD (RE);
455 NEW_RECORD (IM);
456 switch (prec) {
457 case 8: {
458 pretty_real (RE, 4, cxreal (cval));
459 pretty_real (IM, 4, cximag (cval));
460 _srecordf (num, "CMPLXF (%s, %s)", RE, IM);
461 return;
462 }
463 case 16: {
464 pretty_real (RE, 8, cxreal (cval));
465 pretty_real (IM, 8, cximag (cval));
466 _srecordf (num, "CMPLX (%s, %s)", RE, IM);
467 return;
468 }
469 case 32: {
470 pretty_real (RE, 16, cxreal (cval));
471 pretty_real (IM, 16, cximag (cval));
472 _srecordf (num, "CMPLXQ (%s, %s)", RE, IM);
473 return;
474 }
475 }
476 }
477
478 logical_4 fold_intrinsic (INTRINS *F, EXPR *lhs, EXPR *rhs)
479 {
480 if (lhs->variant != EXPR_CONST) {
481 return FALSE;
482 } else if (!valid_expr (lhs)) {
483 return FALSE;
484 } else if (rhs != NO_EXPR && rhs->variant != EXPR_CONST) {
485 return FALSE;
486 } else if (rhs != NO_EXPR && !valid_expr (rhs)) {
487 return FALSE;
488 } else if (F->f3 != NULL && rhs == NO_EXPR) {
489 complex_64 lval;
490 if (! (accept_mode (lhs->mode.type, lhs->mode.len, COMPLEX, 32) && calc_complex (lhs->str, &lval))) {
491 return FALSE;
492 }
493 complex_64 cval = (F->f3) (lval);
494 pretty_complex (lhs->str, F->alen, cval);
495 return TRUE;
496 } else {
497 NEW_RECORD (num);
498 num[0] = '\0';
499 real_32 lval;
500 if (! (accept_mode (lhs->mode.type, lhs->mode.len, REAL, 16) && calc_real (lhs->str, &lval))) {
501 return FALSE;
502 }
503 if (F->f1 != NULL) {
504 // Single-argumenters.
505 pretty_real (num, 32, (F->f1) (lval));
506 }
507 if (rhs != NO_EXPR) {
508 real_32 rval;
509 if (! (accept_mode (rhs->mode.type, rhs->mode.len, REAL, 16) && calc_real (rhs->str, &rval))) {
510 return FALSE;
511 }
512 if (F->f2 != NULL) {
513 // Two-argumenters.
514 pretty_real (num, 32, (F->f2) (lval, rval));
515 }
516 }
517 if (strlen (num) > 0) {
518 RECCPY (lhs->str, num);
519 return TRUE;
520 } else {
521 return FALSE;
522 }
523 }
524 }
525
526 logical_4 fold_expr (EXPR *reg, int_4 expect)
527 {
528 if (reg->variant != EXPR_CONST) {
529 return FALSE;
530 } else if (!valid_expr (reg)) {
531 return FALSE;
532 } else {
533 if ((reg->mode.type == INTEGER || (reg->mode.type == REAL && reg->mode.len <= 16))) {
534 real_32 rval;
535 if (calc_real (reg->str, &rval)) {
536 if (reg->mode.type == INTEGER || expect == INTEGER) {
537 reg->mode.type = INTEGER;
538 reg->mode.len = 4;
539 _srecordf (reg->str, "%d", _xint4 (rval));
540 } else {
541 NEW_RECORD (z);
542 RECCLR (z);
543 pretty_real (z, reg->mode.len, rval);
544 RECCPY (reg->str, z);
545 }
546 return TRUE;
547 } else {
548 return FALSE;
549 }
550 } else if (reg->mode.type == COMPLEX && reg->mode.len <= 32) {
551 complex_64 cval;
552 if (calc_complex (reg->str, &cval)) {
553 pretty_complex (reg->str, reg->mode.len, cval);
554 return TRUE;
555 } else {
556 return FALSE;
557 }
558 } else {
559 return FALSE;
560 }
561 }
562 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
