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 (1401, "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 (1402, "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 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 (1401, INTERNAL_CONSISTENCY, NO_TEXT);
90 }
91 }
92
93 static void factor_real_number (EXPR *loc)
94 {
95 char *expo;
96 RECORD edit;
97 RECCLR (edit);
98 strcpy (edit, curlex);
99 if ((expo = strchr (edit, 'e')) != NO_TEXT || (expo = strchr (edit, 'E')) != NO_TEXT) {
100 loc->mode = (MODE) {.type = REAL, .len = 4, .dim = 0};
101 _srecordf (loc->str, "%s", pretty_float (edit));
102 } else if ((expo = strchr (edit, 'd')) != NO_TEXT || (expo = strchr (edit, 'D')) != NO_TEXT) {
103 *expo = 'e';
104 loc->mode = (MODE) {.type = REAL, .len = 8, .dim = 0};
105 _srecordf (loc->str, "%s", pretty_float (edit));
106 } else if ((expo = strchr (edit, 'q')) != NO_TEXT || (expo = strchr (edit, 'Q')) != NO_TEXT) {
107 *expo = 'e';
108 loc->mode = (MODE) {.type = REAL, .len = 16, .dim = 0};
109 _srecordf (loc->str, "%sq", pretty_float (edit));
110 } else if ((expo = strchr (edit, 'x')) != NO_TEXT || (expo = strchr (edit, 'X')) != NO_TEXT) {
111 *expo = 'e';
112 loc->mode = (MODE) {.type = REAL, .len = 32, .dim = 0};
113 _srecordf (loc->str, "_dc_%d", code_real_32_const (pretty_float (edit)));
114 } else {
115 // No exponent.
116 loc->mode = (MODE) {.type = REAL, .len = 4, .dim = 0};
117 _srecordf (loc->str, "%s", pretty_float (edit));
118 }
119 loc->variant = EXPR_CONST;
120 }
121
122 static void factor_complex_number (EXPR *loc, EXPR lhs)
123 {
124 (void) scan (EXPECT_NONE);
125 EXPR rhs;
126 memset (&rhs, 0, sizeof (rhs));
127 express (&rhs, NOTYPE, 0);
128 int_4 len = mix_len (&lhs, &rhs);
129 if (len == 32) {
130 _srecordf (loc->str, "CMPLXX (%s, %s)", lhs.str, rhs.str);
131 loc->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
132 } else if (len == 16) {
133 _srecordf (loc->str, "CMPLXQ (%s, %s)", lhs.str, rhs.str);
134 loc->mode = (MODE) {.type = COMPLEX, .len = 32, .dim = 0};
135 } else if (len == 8) {
136 _srecordf (loc->str, "CMPLX (%s, %s)", lhs.str, rhs.str);
137 loc->mode = (MODE) {.type = COMPLEX, .len = 16, .dim = 0};
138 } else {
139 _srecordf (loc->str, "CMPLXF (%s, %s)", lhs.str, rhs.str);
140 loc->mode = (MODE) {.type = COMPLEX, .len = 8, .dim = 0};
141 }
142 if (lhs.variant == EXPR_CONST && rhs.variant == EXPR_CONST) {
143 loc->variant = EXPR_CONST;
144 }
145 (void) scan (EXPECT_NONE);
146 }
147
148 void factor (EXPR * reg)
149 {
150 int_4 rc;
151 MODE mode;
152 EXPR loc;
153 RECORD name;
154 bufcpy (name, curlex, RECLN);
155 memset (&loc, 0, sizeof (EXPR));
156 loc.variant = EXPR_OTHER;
157 if (curret == DECLAR) {
158 // Some intrinsics share name with a declarer, like REAL (I).
159 intrinsic_call (name, &loc);
160 memcpy (reg, &loc, sizeof (EXPR));
161 return;
162 } else if (curret == WORD) {
163 IDENT *idf = find_local (name, &mode);
164 logical_4 ext_call = (idf != NO_IDENT && idf->external);
165 if (!ext_call && intrinsic_call (name, &loc)) {
166 // Intrinsic call like SQRT (...).
167 memcpy (reg, &loc, sizeof (EXPR));
168 return;
169 }
170 if (idf != NO_IDENT && idf->intrinsic) {
171 // When passed as an argument, an intrinsic function must be
172 // 'specific' for the mode it accepts, so DSIN and not generic SIN.
173 if (!is_specific (name)) {
174 EXPECT (1403, "specific intrinsic subprogram name");
175 }
176 reg->idf = idf;
177 _srecordf (reg->str, "%s", edit_f (name));
178 reg->variant = EXPR_VAR;
179 return;
180 }
181 if (idf == NO_IDENT || ext_call) {
182 // Undefined locally can mean function call.
183 rc = scan (EXPECT_NONE);
184 if (TOKEN ("(")) {
185 factor_function_call (&loc, name);
186 } else {
187 implicit_name (&loc, idf, &mode, name);
188 }
189 memcpy (reg, &loc, sizeof (EXPR));
190 (void) rc;
191 return;
192 } else {
193 rc = scan (EXPECT_NONE);
194 if (TOKEN ("(")) {
195 idf = impl_decl (name, &mode);
196 if (idf->mode.type == CHARACTER) {
197 factor_slice_char (&loc, idf);
198 if (idf->parm) {
199 loc.mode = idf->mode;
200 loc.variant = EXPR_CONST;
201 }
202 } else if (IS_SCALAR (idf->mode)) {
203 if (strcmp (name, modnam) == 0) {
204 recursion (&loc, modnam, idf);
205 } else if (idf->source == MACRO) {
206 macro_nest++;
207 macro (&loc, idf);
208 macro_nest--;
209 } else {
210 factor_function_call (&loc, name);
211 }
212 } else {
213 // Row slice.
214 factor_slice (&loc, idf);
215 }
216 } else {
217 UNSCAN;
218 if (idf->parm) {
219 bufcat (loc.str, idf->parm, RECLN);
220 loc.mode = idf->mode;
221 loc.variant = EXPR_CONST;
222 } else {
223 idf = impl_decl (name, &mode);
224 factor_variable (&loc, idf, &mode, name);
225 }
226 }
227 }
228 memcpy (reg, &loc, sizeof (EXPR));
229 return;
230 } else if (TOKEN ("+")) {
231 // + factor.
232 EXPR fac;
233 memset (&fac, 0, sizeof (EXPR));
234 rc = scan (EXPECT_NONE);
235 factor (&fac);
236 if (fac.mode.type != INTEGER && fac.mode.type != REAL && fac.mode.type != COMPLEX) {
237 EXPECT (1404, "arithmetical expression");
238 }
239 _srecordf (loc.str, "%s", fac.str);
240 loc.mode = fac.mode;
241 if (fac.variant == EXPR_CONST) {
242 loc.variant = EXPR_CONST;
243 } else {
244 loc.variant = EXPR_OTHER;
245 }
246 } else if (TOKEN ("-")) {
247 // - factor.
248 EXPR fac;
249 memset (&fac, 0, sizeof (EXPR));
250 rc = scan (EXPECT_NONE);
251 factor (&fac);
252 if (fac.mode.type != INTEGER && fac.mode.type != REAL && fac.mode.type != COMPLEX) {
253 EXPECT (1405, "arithmetical expression");
254 }
255 if (fac.mode.type == COMPLEX && fac.mode.len == 64) {
256 _srecordf (loc.str, "cxneg (%s)", fac.str);
257 } else if (fac.mode.type == REAL && fac.mode.len == 32) {
258 _srecordf (loc.str, "xneg (%s)", fac.str);
259 } else {
260 _srecordf (loc.str, "-%s", fac.str);
261 }
262 loc.mode = fac.mode;
263 if (fac.variant == EXPR_CONST) {
264 loc.variant = EXPR_CONST;
265 } else {
266 loc.variant = EXPR_OTHER;
267 }
268 } else if (TOKEN (".true.") || TOKEN (".t.")) {
269 // LOGICAL constant TRUE.
270 _srecordf (loc.str, "TRUE");
271 loc.mode = (MODE) {
272 .type = LOGICAL, .len = 4, .dim = 0};
273 loc.variant = EXPR_CONST;
274 } else if (TOKEN (".false.") || TOKEN (".f.")) {
275 // LOGICAL constant FALSE.
276 _srecordf (loc.str, "FALSE");
277 loc.mode = (MODE) {
278 .type = LOGICAL, .len = 4, .dim = 0};
279 loc.variant = EXPR_CONST;
280 } else if (curret == INT_NUMBER) {
281 // INTEGER constant.
282 factor_integer_number (&loc, curlex);
283 MAXIMISE (loc.mode.len, 4);
284 } else if (curret == FLT_NUMBER) {
285 // REAL constnat.
286 factor_real_number (&loc);
287 } else if (curret == TEXT) {
288 // TEXT constant.
289 RECORD idf;
290 _srecordf (idf, "_dc_%d", code_uniq_str (curlex));
291 _srecordf (loc.str, "%s", idf);
292 int len = strlen (curlex) - 2;
293 if (len < 1) {
294 len = 1;
295 }
296 loc.mode = (MODE) {.type = CHARACTER, .len = len, .dim = 0};
297 norm_mode (&loc.mode);
298 loc.variant = EXPR_CONST;
299 } else if (TOKEN ("(")) {
300 EXPR lhs;
301 memset (&lhs, 0, sizeof (lhs));
302 rc = scan (EXPECT_NONE);
303 express (&lhs, NOTYPE, 0);
304 rc = scan (EXPECT_NONE);
305 if (TOKEN (",")) {
306 // COMPLEX number.
307 factor_complex_number (&loc, lhs);
308 } else {
309 // Parenthesized expression.
310 if (lhs.variant == EXPR_CONST) {
311 loc.variant = EXPR_CONST;
312 _srecordf (loc.str, "%s", lhs.str);
313 } else {
314 loc.variant = EXPR_OTHER;
315 _srecordf (loc.str, "(%s)", lhs.str);
316 }
317 loc.mode = lhs.mode;
318 }
319 CHECKPOINT (1406, ")");
320 } else {
321 ERROR (1407, "expected operand", NO_TEXT);
322 loc.mode.type = ETYPE;
323 }
324 memcpy (reg, &loc, sizeof (EXPR));
325 (void) rc;
326 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
