equivalence.c
1 //! @file equivalence.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 EQUIVALENCE statements.
25
26 // This code compiles pairwise equivalence statements of the form
27 //
28 // EQUIVALENCE (A, B), ...
29 //
30 // Multiple equivalence was allowed by vintage Fortran,
31 // but hardly used (if at all) in practice.
32 // Anyway, VIF compiles
33 //
34 // EQUIVALENCE (A, B, C, D)
35 //
36 // as (Aho, Sethi, Ullman)
37 //
38 // EQUIVALENCE (B, A), (C, A), (D, A)
39 //
40 // Not all EQUIVALENCE statements may work in VIF as VIF neither emulates the
41 // FORTRAN memory model, nor combines equivalence statements. This hardly has
42 // consequences for compiling existing vintage code. Programmers apparently
43 // only need(ed) basic equivalence facilities.
44
45 #include <vif.h>
46
47 static void eq_compute_row_size (IDENT *idf, int_4 *val)
48 {
49 // Compute size of row in bytes.
50 RECORD buf;
51 RECCLR (buf);
52 compute_row_size (buf, idf);
53 if (EQUAL (buf, "VARY")) {
54 ERROR (1201, "varying row in equivalence", NO_TEXT);
55 }
56 if (!isint_4 (buf, val)) {
57 (*val) = 0;
58 }
59 }
60
61 static void eq_var_any (EXPR lhs, EXPR rhs, int_4 *N)
62 {
63 // Link a variable to either variable or row.
64 IDENT *lid = lhs.idf, *rid = rhs.idf; RECORD str;
65 // Redirect if possible.
66 if (lid->equiv != NO_IDENT) {
67 if (rid->equiv == NO_IDENT) {
68 eq_var_any (rhs, lhs, N);
69 } else {
70 _srecordf (str, "(%s, %s)", FTN_NAME (lid), FTN_NAME (rid));
71 ERROR (1202, "cannot alias", str);
72 }
73 return;
74 }
75 // Peephole optimization.
76 RECORD target, buf;
77 RECCLR (target);
78 if (IS_SCALAR (rid->mode)) {
79 _srecordf (target, "&(%s)", rhs.str);
80 } else {
81 if (!isint_4 (rhs.elem, &rhs.value)) {
82 SYNTAX (1203, "rhs must have a constant index");
83 return;
84 }
85 if (rhs.value == 0) {
86 _srecordf (target, "%s", idf_full_c_name (buf, rid));
87 } else {
88 _srecordf (target, "&(%s)", rhs.str);
89 }
90 }
91 // Make alias.
92 if (rid->common != LOCAL) {
93 cpp_direct (nprocs, prelin, REFDECL);
94 _srecordf (str, "static %s %s = %s %s;\n", wtype (&lhs.mode, NOARG, NOFUN), ptr_to_array (lhs.idf, CONST, NOCAST, ACTUAL), ptr_to_array (lhs.idf, NOCONST, CAST, ACTUAL), target);
95 code (nprocs, REFDECL, str);
96 lid->const_ref = TRUE;
97 } else if (lhs.mode.save == STATIC) {
98 if (rhs.mode.save == STATIC) {
99 cpp_direct (nprocs, prelin, REFDECL);
100 _srecordf (str, "static %s %s = %s %s;\n", wtype (&lhs.mode, NOARG, NOFUN), ptr_to_array (lhs.idf, CONST, NOCAST, ACTUAL), ptr_to_array (lhs.idf, NOCONST, CAST, ACTUAL), target);
101 code (nprocs, REFDECL, str);
102 lid->const_ref = TRUE;
103 } else {
104 cpp_direct (nprocs, prelin, EQUIV);
105 _srecordf (str, "%s = %s %s;\n", lhs.str, ptr_to_array (lhs.idf, NOCONST, CAST, ACTUAL), target);
106 code (nprocs, EQUIV, str);
107 N++;
108 }
109 } else {
110 cpp_direct (nprocs, prelin, BODY);
111 _srecordf (str, "%s = %s %s;\n", lhs.str, ptr_to_array (lhs.idf, NOCONST, CAST, ACTUAL), target);
112 code (nprocs, BODY, str);
113 }
114 }
115
116 static void eq_row_row (EXPR lhs, EXPR rhs, int_4 *N)
117 {
118 // Link a row to a row.
119 IDENT *lid = lhs.idf, *rid = rhs.idf; RECORD str;
120 RECORD index, buf;
121 // Peephole optimization.
122 if (lhs.value == rhs.value) {
123 _srecordf (index, "%s", idf_full_c_name (buf, rid));
124 } else {
125 _srecordf (index, "&(%s[%d])", idf_full_c_name (buf, rid), rhs.value - lhs.value);
126 }
127 // Make alias.
128 if (rid->common != LOCAL) {
129 cpp_direct (nprocs, prelin, DECL);
130 _srecordf (str, "static %s %s = %s %s;\n", wtype (&lhs.mode, NOARG, NOFUN), ptr_to_array (lid, CONST, NOCAST, ACTUAL), ptr_to_array (lid, NOCONST, CAST, ACTUAL), index);
131 code (nprocs, DECL, str);
132 lid->const_ref = TRUE;
133 } else {
134 _srecordf (str, "%s = %s %s;\n", C_NAME (lid), ptr_to_array (lid, NOCONST, CAST, ACTUAL), index);
135 if (lhs.mode.save == STATIC) {
136 cpp_direct (nprocs, prelin, EQUIV);
137 code (nprocs, EQUIV, str);
138 N++;
139 } else {
140 cpp_direct (nprocs, prelin, BODY);
141 code (nprocs, BODY, str);
142 }
143 }
144 }
145
146 static void eq_link (EXPR lhs, EXPR rhs, int_4 *N)
147 {
148 IDENT *lid = lhs.idf, *rid = rhs.idf;
149 // Oops!
150 if (lid == NO_IDENT || rid == NO_IDENT) {
151 SYNTAX (1204, "equivalence statement");
152 return;
153 }
154 // ROW -> ROW is mostly OK.
155 if (IS_ROW (lid->mode) && IS_ROW (rid->mode)) {
156 if (!isint_4 (lhs.elem, &lhs.value)) {
157 SYNTAX (1205, "lhs must have a constant index");
158 return;
159 }
160 if (!isint_4 (rhs.elem, &rhs.value)) {
161 SYNTAX (1206, "rhs must have a constant index");
162 return;
163 }
164 int_4 lsz, rsz;
165 eq_compute_row_size (lid, &lsz);
166 eq_compute_row_size (rid, &rsz);
167 // We want the alias to fit in the target.
168 if (rhs.idf->common == LOCAL && (rhs.value <= lhs.value) && (rsz <= lsz - lhs.value)) {
169 rid->alias = lid;
170 lid->equiv = rid;
171 eq_row_row (rhs, lhs, N);
172 } else if (lhs.idf->common == LOCAL && (rhs.value >= lhs.value) && (lsz <= rsz - rhs.value)) {
173 lid->alias = rid;
174 rid->equiv = lid;
175 eq_row_row (lhs, rhs, N);
176 } else {
177 // Alias sticks out to the right.
178 ERROR (1207, "equivalence", "cannot equivalence");
179 }
180 return;
181 }
182 // ROW -> VAR is VAR -> ROW.
183 if (IS_ROW (lid->mode) && IS_SCALAR (rid->mode)) {
184 eq_link (rhs, lhs, N);
185 return;
186 }
187 // Shuffle to avoid multiple equivalencing if possible.
188 if (lid->equiv != NO_IDENT) {
189 if (rid->equiv == NO_IDENT) {
190 eq_link (rhs, lhs, N);
191 return;
192 } else {
193 RECORD str;
194 _srecordf (str, "(%s, %s)", FTN_NAME (lid), FTN_NAME (rid));
195 ERROR (1208, "cannot alias", str);
196 }
197 }
198 // VAR -> VAR is OK.
199 if (IS_SCALAR (lid->mode) && IS_SCALAR (rid->mode)) {
200 lid->alias = rid;
201 rid->equiv = lid;
202 eq_var_any (lhs, rhs, N);
203 }
204 // VAR -> ROW is OK.
205 if (IS_SCALAR (lid->mode) && IS_ROW (rid->mode)) {
206 lid->alias = rid;
207 rid->equiv = lid;
208 eq_var_any (lhs, rhs, N);
209 }
210 }
211
212 void equivalence (void)
213 {
214 // EQUIVALENCE by aliasing already allocated variables or arrays.
215 // We already know that parentheses are balanced.
216 int_4 rc, N = 0;
217 int_4 epatch = code (nprocs, EQUIV, NO_TEXT);
218 while ((rc = scan (EXPECT_NONE)) != END_OF_LINE) {
219 if (TOKEN (",")) {
220 continue;
221 } else if (TOKEN ("(")) {
222 continue;
223 } else if (rc != WORD) {
224 EXPECT (1209, "identifier");
225 } else {
226 IDENT *lid, *rid;
227 EXPR lhs, rhs;
228 MODE lmode, rmode;
229 rid = impl_decl (curlex, &lmode);
230 if (rid->alias != NO_IDENT) {
231 ERROR (1210, "cannot alias", curlex);
232 }
233 factor (&rhs);
234 rc = scan (EXPECT_NONE);
235 if (!TOKEN (",")) {
236 EXPECT (1211, ",");
237 }
238 // Loop resolving multiple equivalence.
239 while (TOKEN (",")) {
240 rc = scan (EXPECT_NONE);
241 if (rc != WORD) {
242 EXPECT (1212, "variable");
243 }
244 lid = impl_decl (curlex, &rmode);
245 factor (&lhs);
246 rc = scan (EXPECT_NONE);
247 // Mistakes.
248 if (lid == NO_IDENT || rid == NO_IDENT) {
249 break;
250 }
251 if (lid->mode.save != rid->mode.save) {
252 ERROR (1213, "aliasing static and automatic", NO_TEXT);
253 break;
254 }
255 if (lid->common != LOCAL && rid->common != LOCAL) {
256 ERROR (1214, "lhs and rhs are in common block", NO_TEXT);
257 break;
258 }
259 // If a row is denoted as variable, address of first element is implied.
260 // Padding "[0]" simplifies code generation.
261 if (lhs.variant == EXPR_VAR && IS_ROW (lid->mode)) {
262 bufcat (lhs.str, "[0]", RECLN);
263 _srecordf (lhs.elem, "0");
264 lhs.value = 0;
265 }
266 if (rhs.variant == EXPR_VAR && IS_ROW (rid->mode)) {
267 bufcat (rhs.str, "[0]", RECLN);
268 _srecordf (rhs.elem, "0");
269 rhs.value = 0;
270 }
271 // Warning!
272 if (lid->mode.type != rid->mode.type || lid->mode.len != rid->mode.len) {
273 RECORD str;
274 _srecordf (str, "equivalence (%s, %s)", qtype (&(rhs.mode)), qtype (&(lhs.mode)));
275 WARNING (1215, "mixed types", str);
276 }
277 // Equivalence in correct order.
278 if (lid->common == LOCAL) {
279 eq_link (lhs, rhs, &N);
280 } else if (rid->common == LOCAL) {
281 eq_link (rhs, lhs, &N);
282 } else {
283 eq_link (lhs, rhs, &N);
284 }
285 }
286 }
287 }
288 if (N > 0) {
289 RECORD str;
290 cpp_direct (nprocs, prelin, EQUIV);
291 _srecordf (str, "if (__calls[%d].calls == 0) {\n", nprocs - 1);
292 patch (epatch, str);
293 code (nprocs, EQUIV, "}\n");
294 }
295 }
296
297 void decl_equiv (void)
298 {
299 int_4 go_on = TRUE;
300 while (go_on) {
301 SAVE_POS;
302 int_4 rc = scan (EXPECT_NONE);
303 if (rc == DECLAR) {
304 skip_card (FALSE);
305 } else if (TOKEN ("implicit")) {
306 skip_card (FALSE);
307 } else if (TOKEN ("save")) {
308 skip_card (FALSE);
309 } else if (TOKEN ("automatic")) {
310 skip_card (FALSE);
311 } else if (TOKEN ("parameter")) {
312 skip_card (FALSE);
313 } else if (TOKEN ("common")) {
314 skip_card (FALSE);
315 } else if (TOKEN ("dimension")) {
316 skip_card (FALSE);
317 } else if (TOKEN ("equivalence")) {
318 equivalence ();
319 skip_card (FALSE);
320 } else if (TOKEN ("external")) {
321 skip_card (FALSE);
322 } else if (TOKEN ("intrinsic")) {
323 skip_card (FALSE);
324 } else if (TOKEN ("data")) {
325 skip_card (FALSE);
326 } else if (strlen (curlex) > 0) {
327 // Backspace and done.
328 RESTORE_POS;
329 go_on = FALSE;
330 }
331 }
332 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
