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-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 //! 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 != NULL && idf->mode.type == NOTYPE && idf->external == FALSE) {
33 ERROR (1401, "variable has no type", CID (idf));
34 }
35 _srecordf (loc->str, "%s", CID (idf));
36 loc->variant = EXPR_VAR;
37 loc->idf = idf;
38 loc->mode = idf->mode;
39 }
40
41 void variable (EXPR *loc, IDENT *idf, MODE *mode, RECORD name)
42 {
43 if (idf == NULL) {
44 idf = impl_decl (name, mode);
45 }
46 if (idf == NULL) {
47 BUG ("cannot store identifier");
48 }
49 if (idf->mode.type == NOTYPE && idf->external == FALSE) {
50 ERROR (1402, "variable has no type", CID (idf));
51 }
52 if (idf->arg || idf->alias != NULL) {
53 if (!is_array (idf->mode)) {
54 // bufcat (loc->str, "*", RECLN);
55 _srecordf (loc->str, "(*%s)", CID (idf), RECLN);
56 } else {
57 _srecordf (loc->str, "%s", CID (idf), RECLN);
58 }
59 // bufcat (loc->str, CID (idf), RECLN);
60 } else {
61 if (idf->common > 0) {
62 bufcat (loc->str, commons[idf->common], RECLN);
63 if (idf->common == EXTERN) {
64 bufcat (loc->str, "->", RECLN);
65 } else {
66 bufcat (loc->str, ".", RECLN);
67 }
68 bufcat (loc->str, CID (idf), RECLN);
69 } else if (idf->nest > 0) {
70 RECORD res;
71 _srecordf (res, "%s", edit_vn (CID (idf), idf->nest));
72 bufcat (loc->str, res, RECLN);
73 } else {
74 bufcat (loc->str, CID (idf), RECLN);
75 }
76 }
77 loc->variant = EXPR_VAR;
78 loc->idf = idf;
79 loc->mode = idf->mode;
80 }
81
82 static void integer_denotation (EXPR *loc)
83 {
84 // We let length depend on the denotation.
85 int_8 val = strtoll (curlex, NULL, 10);
86 loc->variant = EXPR_CONST;
87 if (val >= SHRT_MIN && val <= SHRT_MAX) {
88 _srecordf (loc->str, "%s", curlex);
89 loc->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
90 } else if (val >= INT_MIN && val <= INT_MAX) {
91 _srecordf (loc->str, "%s", curlex);
92 loc->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
93 } else if (val >= LLONG_MIN && val <= LLONG_MAX) {
94 _srecordf (loc->str, "%s", curlex);
95 loc->mode = (MODE) {.type = INTEGER, .len = 8, .dim = 0};
96 }
97 }
98
99 static void real_denotation (EXPR *loc)
100 {
101 char *expo;
102 RECORD edit;
103 RECCLR (edit);
104 strcpy (edit, curlex);
105 if ((expo = strchr (edit, 'e')) != NULL || (expo = strchr (edit, 'E')) != NULL) {
106 loc->mode = (MODE) {.type = REAL, .len = 4, .dim = 0};
107 _srecordf (loc->str, "%s", pretty_float (edit));
108 } else if ((expo = strchr (edit, 'd')) != NULL || (expo = strchr (edit, 'D')) != NULL) {
109 *expo = 'e';
110 loc->mode = (MODE) {.type = REAL, .len = 8, .dim = 0};
111 _srecordf (loc->str, "%s", pretty_float (edit));
112 } else if ((expo = strchr (edit, 'q')) != NULL || (expo = strchr (edit, 'Q')) != NULL) {
113 *expo = 'e';
114 loc->mode = (MODE) {.type = REAL, .len = 16, .dim = 0};
115 _srecordf (loc->str, "%sq", pretty_float (edit));
116 } else if ((expo = strchr (edit, 'x')) != NULL || (expo = strchr (edit, 'X')) != NULL) {
117 *expo = 'e';
118 loc->mode = (MODE) {.type = REAL, .len = 32, .dim = 0};
119 _srecordf (loc->str, "_dc_%d", code_real_32_const (pretty_float (edit)));
120 } else {
121 // No exponent.
122 loc->mode = (MODE) {.type = REAL, .len = 4, .dim = 0};
123 _srecordf (loc->str, "%s", pretty_float (edit));
124 }
125 loc->variant = EXPR_CONST;
126 }
127
128 static void complex_denotation (EXPR *loc, EXPR lhs)
129 {
130 (void) scan (NULL);
131 EXPR rhs;
132 memset (&rhs, 0, sizeof (rhs));
133 express (&rhs, NOTYPE, 0);
134 int_4 len = mix_len (&lhs, &rhs);
135 if (len == 32) {
136 _srecordf (loc->str, "CMPLXX (%s, %s)", lhs.str, rhs.str);
137 loc->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
138 } else if (len == 16) {
139 _srecordf (loc->str, "CMPLXQ (%s, %s)", lhs.str, rhs.str);
140 loc->mode = (MODE) {.type = COMPLEX, .len = 32, .dim = 0};
141 } else if (len == 8) {
142 _srecordf (loc->str, "CMPLX (%s, %s)", lhs.str, rhs.str);
143 loc->mode = (MODE) {.type = COMPLEX, .len = 16, .dim = 0};
144 } else {
145 _srecordf (loc->str, "CMPLXF (%s, %s)", lhs.str, rhs.str);
146 loc->mode = (MODE) {.type = COMPLEX, .len = 8, .dim = 0};
147 }
148 if (lhs.variant == EXPR_CONST && rhs.variant == EXPR_CONST) {
149 loc->variant = EXPR_CONST;
150 }
151 (void) scan (NULL);
152 }
153
154 void factor (EXPR * reg)
155 {
156 int_4 rc;
157 MODE mode;
158 EXPR loc;
159 RECORD name;
160 bufcpy (name, curlex, RECLN);
161 memset (&loc, 0, sizeof (EXPR));
162 loc.variant = EXPR_OTHER;
163 if (curret == DECLAR) { // REAL (I)
164 intrinsic_call (name, &loc);
165 memcpy (reg, &loc, sizeof (EXPR));
166 return;
167 } else if (curret == WORD) {
168 IDENT *idf = find_local (name, &mode);
169 logical_4 ext_call = (idf != NULL && idf->external);
170 if (!ext_call && intrinsic_call (name, &loc)) {
171 memcpy (reg, &loc, sizeof (EXPR));
172 return;
173 }
174 if (idf != NULL && idf->intrinsic) {
175 if (!is_specific (name)) {
176 EXPECT (1403, "specific intrinsic subprogram name");
177 }
178 reg->idf = idf;
179 _srecordf (reg->str, "%s", edit_f (name));
180 reg->variant = EXPR_VAR;
181 return;
182 }
183 if (idf == NULL || ext_call) {
184 rc = scan (NULL);
185 if (TOKEN ("(")) {
186 function_call (&loc, name);
187 } else {
188 implicit_name (&loc, idf, &mode, name);
189 }
190 } else {
191 rc = scan (NULL);
192 if (TOKEN ("(")) {
193 idf = impl_decl (name, &mode);
194 if (idf->mode.type == CHARACTER) {
195 slice_char (&loc, idf);
196 if (idf->parm) {
197 loc.mode = idf->mode;
198 loc.variant = EXPR_CONST;
199 }
200 } else if (idf->mode.dim == 0) {
201 if (strcmp (name, modnam) == 0) {
202 recursion (&loc, modnam, idf);
203 } else if (idf->source == MACRO) {
204 macro_nest++;
205 macro (&loc, idf);
206 macro_nest--;
207 } else {
208 function_call (&loc, name);
209 }
210 } else {
211 // Array slice.
212 slice (&loc, idf);
213 }
214 } else {
215 UNSCAN;
216 if (idf->parm) {
217 bufcat (loc.str, idf->parm, RECLN);
218 loc.mode = idf->mode;
219 loc.variant = EXPR_CONST;
220 } else {
221 idf = impl_decl (name, &mode);
222 variable (&loc, idf, &mode, name);
223 }
224 }
225 }
226 memcpy (reg, &loc, sizeof (EXPR));
227 (void) rc;
228 return;
229 } else if (TOKEN ("+")) {
230 EXPR fac;
231 memset (&fac, 0, sizeof (EXPR));
232 rc = scan (NULL);
233 factor (&fac);
234 if (fac.mode.type != INTEGER && fac.mode.type != REAL && fac.mode.type != COMPLEX) {
235 EXPECT (1404, "arithmetical expression");
236 }
237 _srecordf (loc.str, "%s", fac.str);
238 loc.mode = fac.mode;
239 if (fac.variant == EXPR_CONST) {
240 loc.variant = EXPR_CONST;
241 } else {
242 loc.variant = EXPR_OTHER;
243 }
244 } else if (TOKEN ("-")) {
245 EXPR fac;
246 memset (&fac, 0, sizeof (EXPR));
247 rc = scan (NULL);
248 factor (&fac);
249 if (fac.mode.type != INTEGER && fac.mode.type != REAL && fac.mode.type != COMPLEX) {
250 EXPECT (1405, "arithmetical expression");
251 }
252 if (fac.mode.type == COMPLEX && fac.mode.len == 64) {
253 _srecordf (loc.str, "cxneg (%s)", fac.str);
254 } else if (fac.mode.type == REAL && fac.mode.len == 32) {
255 _srecordf (loc.str, "xneg (%s)", fac.str);
256 } else {
257 _srecordf (loc.str, "-%s", fac.str);
258 }
259 loc.mode = fac.mode;
260 if (fac.variant == EXPR_CONST) {
261 loc.variant = EXPR_CONST;
262 } else {
263 loc.variant = EXPR_OTHER;
264 }
265 } else if (TOKEN (".true.") || TOKEN (".t.")) {
266 _srecordf (loc.str, "TRUE");
267 loc.mode = (MODE) {
268 .type = LOGICAL, .len = 4, .dim = 0};
269 loc.variant = EXPR_CONST;
270 } else if (TOKEN (".false.") || TOKEN (".f.")) {
271 _srecordf (loc.str, "FALSE");
272 loc.mode = (MODE) {
273 .type = LOGICAL, .len = 4, .dim = 0};
274 loc.variant = EXPR_CONST;
275 } else if (curret == INT_NUMBER) {
276 integer_denotation (&loc);
277 } else if (curret == FLT_NUMBER) {
278 real_denotation (&loc);
279 } else if (curret == TEXT) {
280 RECORD idf;
281 _srecordf (idf, "_dc_%d", code_uniq_str (curlex));
282 _srecordf (loc.str, "%s", idf);
283 int len = strlen (curlex) - 2;
284 if (len < 1) {
285 len = 1;
286 }
287 loc.mode = (MODE) {.type = CHARACTER, .len = len, .dim = 0};
288 norm_mode (&loc.mode);
289 loc.variant = EXPR_CONST;
290 } else if (TOKEN ("(")) {
291 EXPR lhs;
292 memset (&lhs, 0, sizeof (lhs));
293 rc = scan (NULL);
294 express (&lhs, NOTYPE, 0);
295 rc = scan (NULL);
296 if (TOKEN (",")) {
297 complex_denotation (&loc, lhs);
298 } else {
299 if (lhs.variant == EXPR_CONST) {
300 loc.variant = EXPR_CONST;
301 _srecordf (loc.str, "%s", lhs.str);
302 } else {
303 loc.variant = EXPR_OTHER;
304 _srecordf (loc.str, "(%s)", lhs.str);
305 }
306 loc.mode = lhs.mode;
307 }
308 CHECKPOINT (1406, ")");
309 } else {
310 ERROR (1407, "expected operand", NULL);
311 loc.mode.type = ETYPE;
312 }
313 memcpy (reg, &loc, sizeof (EXPR));
314 (void) rc;
315 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
