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-2024 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 lval = xdiv (lval, rval);
188 }
189 while ((*s)[0] == ' ') {
190 (*s)++;
191 }
192 }
193 *val = lval;
194 return TRUE;
195 }
196
197 static int_4 calc_real_add (char **s, real_32 *val)
198 {
199 real_32 lval, rval;
200 if (!calc_real_mul (s, &lval)) {
201 return FALSE;
202 }
203 while ((*s)[0] == ' ') {
204 (*s)++;
205 }
206 while ((*s)[0] != '\0' && ((*s)[0] == '+' || (*s)[0] == '-')) {
207 char op = (*s)++[0];
208 if (!calc_real_mul (s, &rval)) {
209 return FALSE;
210 }
211 if (op == '+') {
212 lval = xadd (lval, rval, 0);
213 } else {
214 lval = xadd (lval, rval, 1);
215 }
216 while (isspace (*s[0])) {
217 (*s)++;
218 }
219 }
220 *val = lval;
221 return TRUE;
222 }
223
224 int_4 calc_real (char *p, real_32 *val)
225 {
226 char *q = p;
227 int_4 rc = calc_real_add (&q, val) && (q[0] == '\0');
228 return rc;
229 }
230
231 // COMPLEX
232
233 static int_4 calc_complex_add (char **, complex_64 *);
234
235 int skip (char **q, char *p)
236 {
237 size_t N = strlen (p);
238 if (strncmp (*q, p, N) == 0) {
239 (*q) += N;
240 return TRUE;
241 } else {
242 return FALSE;
243 }
244 }
245
246 static int_4 calc_complex_fact (char **s, complex_64 *val)
247 {
248 while (isspace (*s[0])) {
249 (*s)++;
250 }
251 (void) skip (s, "CMPLXQ");
252 (void) skip (s, "CMPLXF");
253 (void) skip (s, "CMPLX");
254 while (isspace (*s[0])) {
255 (*s)++;
256 }
257 if (isdigit ((*s)[0])) {
258 real_32 z;
259 z = strtox (*s, s);
260 if ((*s)[0] == 'q') {
261 (*s)++;
262 }
263 *val = (complex_64) {z, X_0};
264 return TRUE;
265 } else if ((*s)[0] == '-') {
266 int_4 rc;
267 (*s)++;
268 rc = calc_complex_fact (s, val);
269 *val = cxneg (*val);
270 return rc;
271 } else if ((*s)[0] == '(') {
272 int_4 rc;
273 complex_64 sub;
274 (*s)++;
275 char *t = *s;
276 if (isdigit ((*s)[0]) || (*s)[0] == '+' || (*s)[0] == '-') {
277 real_32 re, im;
278 re = strtox (*s, s);
279 if ((*s)[0] == 'q') {
280 (*s)++;
281 }
282 if ((*s)[0] == ',') {
283 (*s)++;
284 im = strtox (*s, s);
285 if ((*s)[0] == 'q') {
286 (*s)++;
287 }
288 sub = (complex_64) {re, im};
289 rc = TRUE;
290 } else {
291 *s = t;
292 rc = calc_complex_add (s, &sub);
293 }
294 } else {
295 rc = calc_complex_add (s, &sub);
296 }
297 (*s)++; // Assume ')'
298 *val = sub;
299 return rc;
300 }
301 return FALSE;
302 }
303
304 static int_4 calc_complex_mul (char **s, complex_64 *val)
305 {
306 complex_64 lval, rval;
307 if (!calc_complex_fact (s, &lval)) {
308 return FALSE;
309 }
310 while (isspace (*s[0])) {
311 (*s)++;
312 }
313 while ((*s)[0] != '\0' && ((*s)[0] == '*' || (*s)[0] == '/')) {
314 char op = (*s)++[0];
315 if (!calc_complex_fact (s, &rval)) {
316 return FALSE;
317 }
318 if (op == '*') {
319 lval = cxmul (lval, rval);
320 } else if (op == '/') {
321 lval = cxdiv (lval, rval);
322 }
323 while ((*s)[0] == ' ') {
324 (*s)++;
325 }
326 }
327 *val = lval;
328 return TRUE;
329 }
330
331 static int_4 calc_complex_add (char **s, complex_64 *val)
332 {
333 complex_64 lval, rval;
334 if (!calc_complex_mul (s, &lval)) {
335 return FALSE;
336 }
337 while ((*s)[0] == ' ') {
338 (*s)++;
339 }
340 while ((*s)[0] != '\0' && ((*s)[0] == '+' || (*s)[0] == '-')) {
341 char op = (*s)++[0];
342 if (!calc_complex_mul (s, &rval)) {
343 return FALSE;
344 }
345 if (op == '+') {
346 lval = cxsum (lval, rval);
347 } else {
348 lval = cxsub (lval, rval);
349 }
350 while (isspace (*s[0])) {
351 (*s)++;
352 }
353 }
354 *val = lval;
355 return TRUE;
356 }
357
358 int_4 calc_complex (char *p, complex_64 *val)
359 {
360 char *q = p;
361 int_4 rc = calc_complex_add (&q, val) && (q[0] == '\0');
362 return rc;
363 }
364
365 // Drivers.
366
367 char *pretty_float (char *num)
368 {
369 // Cut zero exponent and end-zeroes in floats.
370 RECORD expo;
371 RECCLR (expo);
372 char *e = strchr (num, 'e');
373 if (e != NULL) {
374 _srecordf (expo, "%s", &e[1]);
375 *e = '\0';
376 }
377 RECORD frac;
378 RECCLR (frac);
379 char *f = strchr (num, '.');
380 if (f != NULL) {
381 _srecordf (frac, "%s", &f[1]);
382 *f = '\0';
383 }
384 // Simplify exponent.
385 if (e != NULL) {
386 int expd;
387 sscanf (expo, "%d", &expd);
388 if (expd != 0) {
389 _srecordf (expo, "%d", expd);
390 }
391 }
392 // Simplify fraction.
393 while (strlen (frac) > 0 && frac[strlen (frac) - 1] == '0') {
394 frac[strlen (frac) - 1] = '\0';
395 }
396 // Compose pretty float,
397 if (strlen (frac) > 0) {
398 strcat (num, ".");
399 strcat (num, frac);
400 } else {
401 strcat (num, ".0");
402 }
403 if (strlen (expo) > 0) {
404 strcat (num, "e");
405 strcat (num, expo);
406 }
407 return num;
408 }
409
410 void pretty_number (char *num, int_4 prec, real_32 val)
411 {
412 RECORD stre, strf, fmt;
413 _srecordf (fmt, "%%.%df", prec);
414 _fprintf_real_32 (strf, fmt, val, 5, FLT256_DIG);
415 real_32 valf = strtox (strf, NULL);
416 _srecordf (fmt, "%%.%de", prec);
417 _fprintf_real_32 (stre, fmt, val, 5, FLT256_DIG);
418 real_32 vale = strtox (stre, NULL);
419 if (xeq (vale, valf)) {
420 _srecordf (num, "%s", pretty_float (strf));
421 } else {
422 _srecordf (num, "%s", pretty_float (stre));
423 }
424 }
425
426 void pretty_real (char *num, int_4 prec, real_32 val)
427 {
428 switch (prec) {
429 case 4: {
430 pretty_number (num, FLT_DIG + 1, val);
431 return;
432 }
433 case 8: {
434 pretty_number (num, DBL_DIG + 1, val);
435 return;
436 }
437 case 16: {
438 pretty_number (num, FLT128_DIG + 1, val);
439 bufcat (num, "q", RECLN);
440 return;
441 }
442 case 32: {
443 pretty_number (num, FLT256_DIG, val);
444 return;
445 }
446 }
447 }
448
449 void pretty_complex (char *num, int_4 prec, complex_64 cval)
450 {
451 RECORD RE, IM;
452 switch (prec) {
453 case 8: {
454 pretty_real (RE, 4, cxre (cval));
455 pretty_real (IM, 4, cxim (cval));
456 _srecordf (num, "CMPLXF (%s, %s)", RE, IM);
457 return;
458 }
459 case 16: {
460 pretty_real (RE, 8, cxre (cval));
461 pretty_real (IM, 8, cxim (cval));
462 _srecordf (num, "CMPLX (%s, %s)", RE, IM);
463 return;
464 }
465 case 32: {
466 pretty_real (RE, 16, cxre (cval));
467 pretty_real (IM, 16, cxim (cval));
468 _srecordf (num, "CMPLXQ (%s, %s)", RE, IM);
469 return;
470 }
471 }
472 }
473
474 int_4 fold_intrinsic (INTRINS *F, EXPR *lhs, EXPR *rhs)
475 {
476 if (lhs->variant != EXPR_CONST) {
477 return FALSE;
478 } else if (!valid_expr (lhs)) {
479 return FALSE;
480 } else if (rhs != NULL && rhs->variant != EXPR_CONST) {
481 return FALSE;
482 } else if (rhs != NULL && !valid_expr (rhs)) {
483 return FALSE;
484 } else if (F->f3 != NULL && rhs == NULL) {
485 complex_64 lval;
486 if (! (accept_mode (lhs->mode.type, lhs->mode.len, COMPLEX, 32) && calc_complex (lhs->str, &lval))) {
487 return FALSE;
488 }
489 complex_64 cval = (F->f3) (lval);
490 pretty_complex (lhs->str, F->alen, cval);
491 return TRUE;
492 } else {
493 RECORD num;
494 num[0] = '\0';
495 real_32 lval;
496 if (! (accept_mode (lhs->mode.type, lhs->mode.len, REAL, 16) && calc_real (lhs->str, &lval))) {
497 return FALSE;
498 }
499 if (F->f1 != NULL) {
500 // Single-argumenters.
501 pretty_real (num, 32, (F->f1) (lval));
502 }
503 if (rhs != NULL) {
504 real_32 rval;
505 if (! (accept_mode (rhs->mode.type, rhs->mode.len, REAL, 16) && calc_real (rhs->str, &rval))) {
506 return FALSE;
507 }
508 if (F->f2 != NULL) {
509 // Two-argumenters.
510 pretty_real (num, 32, (F->f2) (lval, rval));
511 }
512 }
513 if (strlen (num) > 0) {
514 strcpy (lhs->str, num);
515 return TRUE;
516 } else {
517 return FALSE;
518 }
519 }
520 }
521
522 int_4 fold_expr (EXPR *reg, int_4 expect)
523 {
524 if (reg->variant != EXPR_CONST) {
525 return FALSE;
526 } else if (!valid_expr (reg)) {
527 return FALSE;
528 } else {
529 if ((reg->mode.type == INTEGER || (reg->mode.type == REAL && reg->mode.len <= 16))) {
530 real_32 rval;
531 if (calc_real (reg->str, &rval)) {
532 if (reg->mode.type == INTEGER || expect == INTEGER) {
533 reg->mode.type = INTEGER;
534 reg->mode.len = 4;
535 _srecordf (reg->str, "%d", _xint4 (rval));
536 } else {
537 RECORD z;
538 RECCLR (z);
539 pretty_real (z, reg->mode.len, rval);
540 strcpy (reg->str, z);
541 }
542 return TRUE;
543 } else {
544 return FALSE;
545 }
546 } else if (reg->mode.type == COMPLEX && reg->mode.len <= 32) {
547 complex_64 cval;
548 if (calc_complex (reg->str, &cval)) {
549 pretty_complex (reg->str, reg->mode.len, cval);
550 return TRUE;
551 } else {
552 return FALSE;
553 }
554 } else {
555 return FALSE;
556 }
557 }
558 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
