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-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 EQUIVALENCE statements.
25
26 #include <vif.h>
27
28 static void eq_var_var_slice (EXPR lhs, EXPR rhs, int_4 *N)
29 {
30 IDENT *lid = lhs.idf, *rid = rhs.idf; RECORD str;
31 if (lid->equiv != NULL) {
32 if (rid->equiv == NULL) {
33 eq_var_var_slice (rhs, lhs, N);
34 } else {
35 _srecordf (str, "(%s, %s)", FID (lid), FID (rid));
36 ERROR (1201, "equivalence", str);
37 }
38 } else if (rid->common != LOCAL) {
39 cpp_direct (nprocs, prelin, REFDECL);
40 _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), rhs.str);
41 code (nprocs, REFDECL, str);
42 lid->const_ref = TRUE;
43 } else if (lhs.mode.save == STATIC) {
44 if (rhs.mode.save == STATIC) {
45 cpp_direct (nprocs, prelin, REFDECL);
46 _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), rhs.str);
47 code (nprocs, REFDECL, str);
48 lid->const_ref = TRUE;
49 } else {
50 cpp_direct (nprocs, prelin, EQUIV);
51 _srecordf (str, "%s = %s &(%s);\n", lhs.str, ptr_to_array (lhs.idf, NOCONST, CAST, ACTUAL), rhs.str);
52 code (nprocs, EQUIV, str);
53 N++;
54 }
55 } else {
56 cpp_direct (nprocs, prelin, BODY);
57 _srecordf (str, "%s = %s &(%s);\n", lhs.str, ptr_to_array (lhs.idf, NOCONST, CAST, ACTUAL), rhs.str);
58 code (nprocs, BODY, str);
59 }
60 }
61
62 static void eq_slice_slice (EXPR lhs, EXPR rhs, int_4 *N)
63 {
64 IDENT *lid = lhs.idf, *rid = rhs.idf; RECORD str;
65 if (rid->common != LOCAL) {
66 cpp_direct (nprocs, prelin, DECL);
67 _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), rhs.str);
68 code (nprocs, DECL, str);
69 lid->const_ref = TRUE;
70 } else {
71 _srecordf (str, "%s = %s &(%s);\n", CID (lid), ptr_to_array (lid, NOCONST, CAST, ACTUAL), rhs.str);
72 if (lhs.mode.save == STATIC) {
73 cpp_direct (nprocs, prelin, EQUIV);
74 code (nprocs, EQUIV, str);
75 N++;
76 } else {
77 cpp_direct (nprocs, prelin, BODY);
78 code (nprocs, BODY, str);
79 }
80 }
81 }
82
83 static void eq_link (EXPR lhs, EXPR rhs, int_4 *N)
84 {
85 IDENT *lid = lhs.idf, *rid = rhs.idf;
86 if (lid == NULL || rid == NULL) {
87 ERROR (1202, "equivalence", "arguments");
88 return;
89 }
90 // ROW -> VAR is VAR -> ROW.
91 if (lid->mode.dim != 0 && rid->mode.dim == 0) {
92 eq_link (rhs, lhs, N);
93 return;
94 }
95 // Shuffle when needed.
96 if (lid->equiv != NULL) {
97 if (rid->equiv == NULL) {
98 eq_link (rhs, lhs, N);
99 return;
100 } else {
101 RECORD str;
102 _srecordf (str, "(%s, %s)", FID (lid), FID (rid));
103 ERROR (1203, "equivalence", str);
104 }
105 }
106 lid->alias = rid;
107 rid->equiv = lid;
108 // VAR -> VAR is OK.
109 if (lid->mode.dim == 0 && rid->mode.dim == 0) {
110 eq_var_var_slice (lhs, rhs, N);
111 }
112 // VAR -> ROW is OK.
113 if (lid->mode.dim == 0 && rid->mode.dim != 0) {
114 eq_var_var_slice (lhs, rhs, N);
115 }
116 // ROW -> ROW is sometimes OK. This is a VIF limitation.
117 if (lid->mode.dim != 0 && rid->mode.dim != 0) {
118 if (!lhs.base_elem) {
119 SYNTAX (1204, "restricted to first array element");
120 return;
121 }
122 eq_slice_slice (lhs, rhs, N);
123 }
124 }
125
126 void equivalence (void)
127 {
128 // EQUIVALENCE is limited to making aliases to already allocated
129 // variables or arrays (which is the common application anyway).
130 //
131 int_4 rc, N = 0;
132 int_4 epatch = code (nprocs, EQUIV, NULL);
133 while ((rc = scan (NULL)) != END_OF_LINE) {
134 if (TOKEN (",")) {
135 continue;
136 } else if (TOKEN ("(")) {
137 continue;
138 } else if (rc != WORD) {
139 SYNTAX (1205, NULL);
140 } else {
141 IDENT *lid, *rid;
142 EXPR lhs, rhs;
143 MODE lmode, rmode;
144 lid = impl_decl (curlex, &lmode);
145 if (lid->alias != NULL) {
146 ERROR (1206, "multiple equivalencing", curlex);
147 }
148 factor (&lhs);
149 rc = scan (NULL);
150 if (!TOKEN (",")) {
151 EXPECT (1207, ",");
152 }
153 rc = scan (NULL);
154 if (rc != WORD) {
155 EXPECT (1208, "variable");
156 }
157 rid = impl_decl (curlex, &rmode);
158 factor (&rhs);
159 rc = scan (NULL);
160 // Mistakes.
161 if (lid->mode.save != rid->mode.save) {
162 ERROR (1209, "aliasing static and automatic", NULL);
163 continue;
164 }
165 if (lid->common != LOCAL && rid->common != LOCAL) {
166 ERROR (1210, "both elements are common", NULL);
167 continue;
168 }
169 // If a row is denoted as variable, address of first element is implied.
170 // Padding "[0]" simplifies code generation.
171 if (lhs.variant == EXPR_VAR && lid->mode.dim != 0) {
172 bufcat (lhs.str, "[0]", RECLN);
173 lhs.base_elem = TRUE;
174 }
175 if (rhs.variant == EXPR_VAR && rid->mode.dim != 0) {
176 bufcat (rhs.str, "[0]", RECLN);
177 rhs.base_elem = TRUE;
178 }
179 // Equivalence in correct order.
180 if (lid->common == LOCAL) {
181 eq_link (lhs, rhs, &N);
182 } else if (rid->common == LOCAL) {
183 eq_link (rhs, lhs, &N);
184 } else {
185 eq_link (lhs, rhs, &N);
186 }
187 }
188 }
189 if (N > 0) {
190 RECORD str;
191 cpp_direct (nprocs, prelin, EQUIV);
192 _srecordf (str, "if (__calls[%d].calls == 0) {\n", nprocs - 1);
193 patch (epatch, str);
194 code (nprocs, EQUIV, "}\n");
195 }
196 }
197
198 void decl_equiv (void)
199 {
200 int_4 go_on = TRUE;
201 while (go_on) {
202 SAVE_POS;
203 int_4 rc = scan (NULL);
204 if (rc == DECLAR) {
205 skip_card ();
206 } else if (TOKEN ("implicit")) {
207 skip_card ();
208 } else if (TOKEN ("save")) {
209 skip_card ();
210 } else if (TOKEN ("automatic")) {
211 skip_card ();
212 } else if (TOKEN ("parameter")) {
213 skip_card ();
214 } else if (TOKEN ("common")) {
215 skip_card ();
216 } else if (TOKEN ("dimension")) {
217 skip_card ();
218 } else if (TOKEN ("equivalence")) {
219 equivalence ();
220 skip_card ();
221 } else if (TOKEN ("external")) {
222 skip_card ();
223 } else if (TOKEN ("intrinsic")) {
224 skip_card ();
225 } else if (TOKEN ("data")) {
226 skip_card ();
227 } else if (strlen (curlex) > 0) {
228 // Backspace and done.
229 RESTORE_POS;
230 go_on = FALSE;
231 }
232 }
233 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
