factor.c
1 //! @file factor.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 //! Compile Fortran expression factors.
25
26 #include <vif.h>
27
28 static void implicit_name (EXPR *loc, IDENT *idf, MODE *mode, RECORD name)
29 {
30 UNSCAN;
31 idf = impl_decl (name, mode);
32 if (idf != NO_IDENT && idf->mode.type == NOTYPE && idf->external == FALSE) {
33 ERROR (1601, "variable has no type", C_NAME (idf));
34 }
35 _srecordf (loc->str, "%s", C_NAME (idf));
36 loc->variant = EXPR_VAR;
37 loc->idf = idf;
38 loc->mode = idf->mode;
39 }
40
41 void factor_variable (EXPR *loc, IDENT *idf, MODE *mode, RECORD name)
42 {
43 if (idf == NO_IDENT) {
44 idf = impl_decl (name, mode);
45 }
46 if (idf == NO_IDENT) {
47 BUG ("cannot store identifier");
48 }
49 if (idf->mode.type == NOTYPE && idf->external == FALSE) {
50 ERROR (1602, "variable has no type", FTN_NAME (idf));
51 }
52 if (idf->arg || idf->alias != NO_IDENT) {
53 if (IS_ROW (idf->mode) || idf->mode.type == CHARACTER) {
54 _srecordf (loc->str, "%s", C_NAME (idf), RECLN);
55 } else {
56 _srecordf (loc->str, "(*%s)", C_NAME (idf), RECLN);
57 }
58 } else {
59 if (NOT_LOCAL (idf)) {
60 (void) idf_full_c_name (loc->str, idf);
61 } else if (idf->nest > 0) {
62 NEW_RECORD (res);
63 _srecordf (res, "%s", edit_vn (C_NAME (idf), idf->nest));
64 bufcat (loc->str, res, RECLN);
65 } else {
66 bufcat (loc->str, C_NAME (idf), RECLN);
67 }
68 }
69 loc->variant = EXPR_VAR;
70 loc->idf = idf;
71 loc->mode = idf->mode;
72 }
73
74 void factor_integer_number (EXPR *loc, char *str)
75 {
76 // We let length depend on the denotation.
77 int_8 val = strtoll (str, NO_REF_TEXT, 10);
78 loc->variant = EXPR_CONST;
79 if (val >= SHRT_MIN && val <= SHRT_MAX) {
80 _srecordf (loc->str, "%s", str);
81 loc->mode = (MODE) {.type = INTEGER, .len = 2, .dim = 0};
82 } else if (val >= INT_MIN && val <= INT_MAX) {
83 _srecordf (loc->str, "%s", str);
84 loc->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
85 } else if (val >= LLONG_MIN && val <= LLONG_MAX) {
86 _srecordf (loc->str, "%s", str);
87 loc->mode = (MODE) {.type = INTEGER, .len = 8, .dim = 0};
88 } else {
89 FATAL (1603, INTERNAL_CONSISTENCY, NO_TEXT);
90 }
91 }
92
93 static void factor_real_number (EXPR *loc)
94 {
95 char *expo;
96 NEW_RECORD (edit);
97 RECCPY (edit, curlex);
98 if ((expo = strchr (edit, 'e')) != NO_TEXT || (expo = strchr (edit, 'E')) != NO_TEXT) {
99 loc->mode = (MODE) {.type = REAL, .len = 4, .dim = 0};
100 _srecordf (loc->str, "%s", pretty_float (edit));
101 } else if ((expo = strchr (edit, 'd')) != NO_TEXT || (expo = strchr (edit, 'D')) != NO_TEXT) {
102 *expo = 'e';
103 loc->mode = (MODE) {.type = REAL, .len = 8, .dim = 0};
104 _srecordf (loc->str, "%s", pretty_float (edit));
105 } else if ((expo = strchr (edit, 'q')) != NO_TEXT || (expo = strchr (edit, 'Q')) != NO_TEXT) {
106 *expo = 'e';
107 loc->mode = (MODE) {.type = REAL, .len = 16, .dim = 0};
108 _srecordf (loc->str, "%sq", pretty_float (edit));
109 } else if ((expo = strchr (edit, 'x')) != NO_TEXT || (expo = strchr (edit, 'X')) != NO_TEXT) {
110 *expo = 'e';
111 loc->mode = (MODE) {.type = REAL, .len = 32, .dim = 0};
112 _srecordf (loc->str, "_dc_%d", code_real_32_const (pretty_float (edit)));
113 } else {
114 // No exponent.
115 loc->mode = (MODE) {.type = REAL, .len = 4, .dim = 0};
116 _srecordf (loc->str, "%s", pretty_float (edit));
117 }
118 loc->variant = EXPR_CONST;
119 }
120
121 static void factor_complex_number (EXPR *loc, EXPR lhs)
122 {
123 (void) scan (EXPECT_NONE);
124 EXPR rhs;
125 memset (&rhs, 0, sizeof (rhs));
126 express (&rhs, NOTYPE, 0);
127 int_4 len = mix_len (&lhs, &rhs);
128 if (len == 32) {
129 _srecordf (loc->str, "CMPLXX (%s, %s)", lhs.str, rhs.str);
130 loc->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
131 } else if (len == 16) {
132 _srecordf (loc->str, "CMPLXQ (%s, %s)", lhs.str, rhs.str);
133 loc->mode = (MODE) {.type = COMPLEX, .len = 32, .dim = 0};
134 } else if (len == 8) {
135 _srecordf (loc->str, "CMPLX (%s, %s)", lhs.str, rhs.str);
136 loc->mode = (MODE) {.type = COMPLEX, .len = 16, .dim = 0};
137 } else {
138 _srecordf (loc->str, "CMPLXF (%s, %s)", lhs.str, rhs.str);
139 loc->mode = (MODE) {.type = COMPLEX, .len = 8, .dim = 0};
140 }
141 if (lhs.variant == EXPR_CONST && rhs.variant == EXPR_CONST) {
142 loc->variant = EXPR_CONST;
143 }
144 (void) scan (EXPECT_NONE);
145 }
146
147 void factor (EXPR * reg)
148 {
149 int_4 rc;
150 MODE mode;
151 EXPR loc;
152 NEW_RECORD (name);
153 bufcpy (name, curlex, RECLN);
154 memset (&loc, 0, sizeof (EXPR));
155 loc.variant = EXPR_OTHER;
156 if (curret == WORD || curret == DECLAR) {
157 IDENT *idf = find_local (name, &mode);
158 logical_4 pack = lookahead ("(");
159 if (curret == DECLAR && pack) {
160 // Some intrinsics share name with a declarer, like REAL (I).
161 intrinsic_call (name, &loc);
162 memcpy (reg, &loc, sizeof (EXPR));
163 return;
164 }
165 if (idf != NO_IDENT && idf->intrinsic && !pack) {
166 // Intrinsic function as parameter must be 'specific'.
167 // Otherwise ambiguity results -> implementation dependent result.
168 // implicit dcos
169 // call zeroin (dcos, ...)
170 if (!is_specific (name)) {
171 EXPECT (1604, "generic intrinsic subprogram name");
172 }
173 reg->idf = idf;
174 _srecordf (reg->str, "%s", edit_i (name));
175 reg->variant = EXPR_VAR;
176 return;
177 }
178 if (idf != NO_IDENT && idf->intrinsic && pack) {
179 // intrinsic dcos
180 // ... dcos (x)
181 rc = scan (EXPECT_NONE);
182 if (TOKEN ("(")) {
183 factor_function_call (&loc, name);
184 }
185 memcpy (reg, &loc, sizeof (EXPR));
186 (void) rc;
187 return;
188 }
189 if (! (idf != NO_IDENT && idf->external)) {
190 // Not a call to a declared external name.
191 logical_4 int_call = FALSE;
192 if (idf != NO_IDENT && idf->intrinsic && pack) {
193 int_call = intrinsic_call (name, &loc);
194 } else if (idf == NO_IDENT) {
195 int_call = intrinsic_call (name, &loc);
196 }
197 if (int_call) {
198 memcpy (reg, &loc, sizeof (EXPR));
199 return;
200 }
201 }
202 if (idf != NO_IDENT && idf->mode.dim == 0 && !idf->intrinsic && !idf->external && pack) {
203 // Name is declared but not as intrinsic or external.
204 // In VIF this gives a check on function return type.
205 // real*8 cos
206 // y = cos (1.0d0)
207 if (is_intrins (name, NO_MODE)) {
208 if (intrinsic_call (name, &loc)) {
209 if (!accept_mode (loc.mode.type, loc.mode.len, idf->mode.type, idf->mode.len)) {
210 MODE_ERROR (1605, qtype (&(loc.mode)), qtype (&(idf->mode)));
211 }
212 memcpy (reg, &loc, sizeof (EXPR));
213 return;
214 }
215 }
216 }
217 if (idf == NO_IDENT || idf->external) {
218 // Undefined locally can mean function call.
219 // In VIF, 'external' always means you supply the routine.
220 // external cos
221 // call zeroin (cos, ...)
222 rc = scan (EXPECT_NONE);
223 if (TOKEN ("(")) {
224 factor_function_call (&loc, name);
225 } else {
226 implicit_name (&loc, idf, &mode, name);
227 }
228 memcpy (reg, &loc, sizeof (EXPR));
229 (void) rc;
230 return;
231 }
232 //
233 if (pack) {
234 rc = scan (EXPECT_NONE);
235 idf = impl_decl (name, &mode);
236 if (idf->mode.type == CHARACTER) {
237 factor_slice_char (&loc, idf);
238 if (idf->parm) {
239 loc.mode = idf->mode;
240 loc.variant = EXPR_CONST;
241 }
242 } else if (IS_SCALAR (idf->mode)) {
243 if (strcmp (name, modnam) == 0) {
244 recursion (&loc, modnam, idf);
245 } else if (idf->source == MACRO) {
246 macro (&loc, idf);
247 } else {
248 factor_function_call (&loc, name);
249 }
250 } else {
251 // Row slice.
252 factor_slice (&loc, idf);
253 }
254 } else {
255 if (idf->parm) {
256 bufcat (loc.str, idf->parm, RECLN);
257 loc.mode = idf->mode;
258 loc.variant = EXPR_CONST;
259 } else {
260 idf = impl_decl (name, &mode);
261 factor_variable (&loc, idf, &mode, name);
262 }
263 }
264 memcpy (reg, &loc, sizeof (EXPR));
265 return;
266 } else if (TOKEN ("+")) {
267 // + factor.
268 EXPR fac;
269 memset (&fac, 0, sizeof (EXPR));
270 rc = scan (EXPECT_NONE);
271 factor (&fac);
272 if (fac.mode.type != INTEGER && fac.mode.type != REAL && fac.mode.type != COMPLEX) {
273 EXPECT (1606, "arithmetical expression");
274 }
275 _srecordf (loc.str, "%s", fac.str);
276 loc.mode = fac.mode;
277 if (fac.variant == EXPR_CONST) {
278 loc.variant = EXPR_CONST;
279 } else {
280 loc.variant = EXPR_OTHER;
281 }
282 } else if (TOKEN ("-")) {
283 // - factor.
284 EXPR fac;
285 memset (&fac, 0, sizeof (EXPR));
286 rc = scan (EXPECT_NONE);
287 factor (&fac);
288 if (fac.mode.type != INTEGER && fac.mode.type != REAL && fac.mode.type != COMPLEX) {
289 EXPECT (1607, "arithmetical expression");
290 }
291 if (fac.mode.type == COMPLEX && fac.mode.len == 64) {
292 _srecordf (loc.str, "cxneg (%s)", fac.str);
293 } else if (fac.mode.type == REAL && fac.mode.len == 32) {
294 _srecordf (loc.str, "xneg (%s)", fac.str);
295 } else {
296 _srecordf (loc.str, "-%s", fac.str);
297 }
298 loc.mode = fac.mode;
299 if (fac.variant == EXPR_CONST) {
300 loc.variant = EXPR_CONST;
301 } else {
302 loc.variant = EXPR_OTHER;
303 }
304 } else if (TOKEN (".true.") || TOKEN (".t.")) {
305 // LOGICAL constant TRUE.
306 _srecordf (loc.str, "TRUE");
307 loc.mode = (MODE) {
308 .type = LOGICAL, .len = 4, .dim = 0};
309 loc.variant = EXPR_CONST;
310 } else if (TOKEN (".false.") || TOKEN (".f.")) {
311 // LOGICAL constant FALSE.
312 _srecordf (loc.str, "FALSE");
313 loc.mode = (MODE) {
314 .type = LOGICAL, .len = 4, .dim = 0};
315 loc.variant = EXPR_CONST;
316 } else if (curret == INT_NUMBER) {
317 // INTEGER constant.
318 factor_integer_number (&loc, curlex);
319 MAXIMISE (loc.mode.len, 4);
320 } else if (curret == FLT_NUMBER) {
321 // REAL constnat.
322 factor_real_number (&loc);
323 } else if (curret == TEXT) {
324 // TEXT constant.
325 NEW_RECORD (idf);
326 _srecordf (idf, "_dc_%d", code_uniq_str (curlex));
327 _srecordf (loc.str, "%s", idf);
328 int len = strlen (curlex) - 2;
329 if (len < 1) {
330 len = 1;
331 }
332 loc.mode = (MODE) {.type = CHARACTER, .len = len, .dim = 0};
333 norm_mode (&loc.mode);
334 loc.variant = EXPR_CONST;
335 } else if (TOKEN ("(")) {
336 EXPR lhs;
337 memset (&lhs, 0, sizeof (lhs));
338 rc = scan (EXPECT_NONE);
339 express (&lhs, NOTYPE, 0);
340 rc = scan (EXPECT_NONE);
341 if (TOKEN (",")) {
342 // COMPLEX number.
343 factor_complex_number (&loc, lhs);
344 } else {
345 // Parenthesized expression.
346 if (lhs.variant == EXPR_CONST) {
347 loc.variant = EXPR_CONST;
348 _srecordf (loc.str, "%s", lhs.str);
349 } else {
350 loc.variant = EXPR_OTHER;
351 _srecordf (loc.str, "(%s)", lhs.str);
352 }
353 loc.mode = lhs.mode;
354 }
355 CHECKPOINT (1608, ")");
356 } else {
357 ERROR (1609, "expected operand", NO_TEXT);
358 loc.mode.type = ETYPE;
359 }
360 memcpy (reg, &loc, sizeof (EXPR));
361 (void) rc;
362 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
