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