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 (1701, "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 (1702, "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 (1703, 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 (1704, "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 INTRINS *fun;
208 if (is_intrins (name, &fun)) {
209 if (intrinsic_call (name, &loc)) {
210 if (!accept_mode (loc.mode.type, loc.mode.len, idf->mode.type, idf->mode.len)) {
211 MODE_ERROR (1705, qtype (&(loc.mode)), qtype (&(idf->mode)));
212 }
213 memcpy (reg, &loc, sizeof (EXPR));
214 return;
215 }
216 }
217 }
218 if (idf == NO_IDENT || idf->external) {
219 // Undefined locally can mean function call.
220 // In VIF, 'external' always means you supply the routine.
221 // external cos
222 // call zeroin (cos, ...)
223 rc = scan (EXPECT_NONE);
224 if (TOKEN ("(")) {
225 factor_function_call (&loc, name);
226 } else {
227 implicit_name (&loc, idf, &mode, name);
228 }
229 memcpy (reg, &loc, sizeof (EXPR));
230 (void) rc;
231 return;
232 }
233 //
234 if (pack) {
235 rc = scan (EXPECT_NONE);
236 idf = impl_decl (name, &mode);
237 if (idf->mode.type == CHARACTER) {
238 factor_slice_char (&loc, idf);
239 if (idf->parm) {
240 loc.mode = idf->mode;
241 loc.variant = EXPR_CONST;
242 }
243 } else if (IS_SCALAR (idf->mode)) {
244 if (strcmp (name, modnam) == 0) {
245 recursion (&loc, modnam, idf);
246 } else if (idf->source == MACRO) {
247 macro (&loc, idf);
248 } else {
249 factor_function_call (&loc, name);
250 }
251 } else {
252 // Row slice.
253 factor_slice (&loc, idf);
254 }
255 } else {
256 if (idf->parm) {
257 bufcat (loc.str, idf->parm, RECLN);
258 loc.mode = idf->mode;
259 loc.variant = EXPR_CONST;
260 } else {
261 idf = impl_decl (name, &mode);
262 factor_variable (&loc, idf, &mode, name);
263 }
264 }
265 memcpy (reg, &loc, sizeof (EXPR));
266 return;
267 } else if (TOKEN ("+")) {
268 // + factor.
269 EXPR fac;
270 memset (&fac, 0, sizeof (EXPR));
271 rc = scan (EXPECT_NONE);
272 factor (&fac);
273 if (fac.mode.type != INTEGER && fac.mode.type != REAL && fac.mode.type != COMPLEX) {
274 EXPECT (1706, "arithmetical expression");
275 }
276 _srecordf (loc.str, "%s", fac.str);
277 loc.mode = fac.mode;
278 if (fac.variant == EXPR_CONST) {
279 loc.variant = EXPR_CONST;
280 } else {
281 loc.variant = EXPR_OTHER;
282 }
283 } else if (TOKEN ("-")) {
284 // - factor.
285 EXPR fac;
286 memset (&fac, 0, sizeof (EXPR));
287 rc = scan (EXPECT_NONE);
288 factor (&fac);
289 if (fac.mode.type != INTEGER && fac.mode.type != REAL && fac.mode.type != COMPLEX) {
290 EXPECT (1707, "arithmetical expression");
291 }
292 if (fac.mode.type == COMPLEX && fac.mode.len == 64) {
293 _srecordf (loc.str, "cxneg (%s)", fac.str);
294 } else if (fac.mode.type == REAL && fac.mode.len == 32) {
295 _srecordf (loc.str, "xneg (%s)", fac.str);
296 } else {
297 _srecordf (loc.str, "-%s", fac.str);
298 }
299 loc.mode = fac.mode;
300 if (fac.variant == EXPR_CONST) {
301 loc.variant = EXPR_CONST;
302 } else {
303 loc.variant = EXPR_OTHER;
304 }
305 } else if (TOKEN (".true.") || TOKEN (".t.")) {
306 // LOGICAL constant TRUE.
307 _srecordf (loc.str, "TRUE");
308 loc.mode = (MODE) {
309 .type = LOGICAL, .len = 4, .dim = 0};
310 loc.variant = EXPR_CONST;
311 } else if (TOKEN (".false.") || TOKEN (".f.")) {
312 // LOGICAL constant FALSE.
313 _srecordf (loc.str, "FALSE");
314 loc.mode = (MODE) {
315 .type = LOGICAL, .len = 4, .dim = 0};
316 loc.variant = EXPR_CONST;
317 } else if (curret == INT_NUMBER) {
318 // INTEGER constant.
319 factor_integer_number (&loc, curlex);
320 MAXIMISE (loc.mode.len, 4);
321 } else if (curret == FLT_NUMBER) {
322 // REAL constnat.
323 factor_real_number (&loc);
324 } else if (curret == TEXT) {
325 // TEXT constant.
326 NEW_RECORD (idf);
327 _srecordf (idf, "_dc_%d", code_uniq_str (curlex));
328 _srecordf (loc.str, "%s", idf);
329 int len = strlen (curlex) - 2;
330 if (len < 1) {
331 len = 1;
332 }
333 loc.mode = (MODE) {.type = CHARACTER, .len = len, .dim = 0};
334 norm_mode (&loc.mode);
335 loc.variant = EXPR_CONST;
336 } else if (TOKEN ("(")) {
337 EXPR lhs;
338 memset (&lhs, 0, sizeof (lhs));
339 rc = scan (EXPECT_NONE);
340 express (&lhs, NOTYPE, 0);
341 rc = scan (EXPECT_NONE);
342 if (TOKEN (",")) {
343 // COMPLEX number.
344 factor_complex_number (&loc, lhs);
345 } else {
346 // Parenthesized expression.
347 if (lhs.variant == EXPR_CONST) {
348 loc.variant = EXPR_CONST;
349 _srecordf (loc.str, "%s", lhs.str);
350 } else {
351 loc.variant = EXPR_OTHER;
352 _srecordf (loc.str, "(%s)", lhs.str);
353 }
354 loc.mode = lhs.mode;
355 }
356 CHECKPOINT (1708, ")");
357 } else {
358 ERROR (1709, "expected operand", NO_TEXT);
359 loc.mode.type = ETYPE;
360 }
361 memcpy (reg, &loc, sizeof (EXPR));
362 (void) rc;
363 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
