decls.c
1 //! @file decls.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 declarations.
25
26 #include <vif.h>
27
28 void idfs_reset (void)
29 {
30 // Before explicit declarations reset implicit ones.
31 // Then do explicit declarations, followed by implicit ones.
32 int_4 k;
33 for (k = 0; k < nlocals; k++) {
34 IDENT *idf = &locals[k];
35 if (idf->parm == NULL && !idf->mode.fun) {
36 idf->mode.type = NOTYPE;
37 }
38 }
39 }
40
41 void idfs_unused (void)
42 {
43 // Before explicit declarations reset implicit ones.
44 // Then do explicit declarations, followed by implicit ones.
45 int_4 k;
46 for (k = 0; k < nlocals; k++) {
47 IDENT *idf = &locals[k];
48 idf->used = FALSE;
49 }
50 }
51
52 void get_init (IDENT *idf, MODE *mode)
53 {
54 EXPR reg;
55 memset (®, 0, sizeof (EXPR));
56 (void) scan (NULL);
57 factor (®);
58 if (accept_mode (reg.mode.type, reg.mode.len, mode->type, mode->len)) {
59 cpp_direct (nprocs, prelin, BODY);
60 RECORD str;
61 if (mode->type == CHARACTER) {
62 _srecordf (str, "bufcpy (%s, %s, %d);\n", CID (idf), reg.str, mode->len);
63 } else {
64 _srecordf (str, "%s = %s;\n", CID (idf), reg.str);
65 }
66 code (nprocs, BODY, str);
67 } else {
68 ERROR (801, "expect type", qtype (mode));
69 }
70 }
71
72 void dec_local (void)
73 {
74 int_4 rc;
75 MODE mode;
76 RECORD base;
77 RECCLR (base);
78 strcpy (base, curlex);
79 // Remove length specification.
80 char *star = strchr (base, '*');
81 if (star != NULL) {
82 *star = '\0';
83 }
84 //
85 f2c_type (curlex, &mode, NOARG, NOFUN);
86 rc = scan (NULL);
87 if (rc == END_OF_LINE) {
88 EXPECT (802, "identifier");
89 }
90 while (rc != END_OF_LINE) {
91 IDENT *idf = NULL;
92 // Identifier, store with leading mode unless length N is specified as idf*N.
93 RECORD name;
94 if (rc != WORD) {
95 EXPECT (803, "identifier");
96 } else {
97 strcpy (name, curlex);
98 rc = scan (NULL);
99 if (!TOKEN ("*")) {
100 // identifier
101 idf = add_local (name, mode.type, mode.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
102 } else {
103 // identifier*length
104 RECORD length;
105 rc = scan (NULL);
106 bufcpy (length, curlex, RECLN);
107 if (TOKEN ("(")) {
108 // identifier*(length)
109 rc = scan (NULL);
110 bufcpy (length, curlex, RECLN);
111 (void) scan (")");
112 }
113 if (rc == WORD) {
114 IDENT *ldf = find_local (length, NULL);
115 if (ldf == NULL || ldf->parm == NULL) {
116 SYNTAX (804, length);
117 } else if (ldf->mode.type != INTEGER) {
118 EXPECT (805, "integer");
119 } else {
120 RECORD new;
121 RECCLR (new);
122 snprintf (new, RECLN, "%s*%s", base, ldf->parm);
123 MODE mode_n;
124 f2c_type (new, &mode_n, NOARG, NOFUN);
125 norm_mode (&mode_n);
126 idf = add_local (name, mode_n.type, mode_n.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
127 }
128 rc = scan (NULL);
129 } else if (rc == INT_NUMBER || EQUAL (length, "*")) {
130 RECORD new;
131 RECCLR (new);
132 MODE mode_n;
133 if (EQUAL (length, "*")) {
134 snprintf (new, RECLN, "%s*(*)", base);
135 } else {
136 snprintf (new, RECLN, "%s*%s", base, length);
137 }
138 f2c_type (new, &mode_n, NOARG, NOFUN);
139 norm_mode (&mode_n);
140 idf = add_local (name, mode_n.type, mode_n.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
141 rc = scan (NULL);
142 } else {
143 SYNTAX (806, name);
144 }
145 }
146 //
147 }
148 if (TOKEN ("(") && idf != NULL) {
149 if (idf->mode.dim != 0) {
150 ERROR (807, "already dimensioned", CID (idf));
151 }
152 get_dims (idf, 1);
153 rc = scan (NULL);
154 if (TOKEN ("*")) {
155 RECORD length;
156 rc = scan (NULL);
157 bufcpy (length, curlex, RECLN);
158 if (TOKEN ("(")) {
159 // identifier*(length)
160 rc = scan (NULL);
161 bufcpy (length, curlex, RECLN);
162 (void) scan (")");
163 }
164 if (rc == WORD) {
165 IDENT *ldf = find_local (length, NULL);
166 if (ldf == NULL || ldf->parm == NULL) {
167 SYNTAX (808, length);
168 } else if (ldf->mode.type != INTEGER) {
169 EXPECT (809, "integer");
170 } else {
171 RECORD new;
172 RECCLR (new);
173 snprintf (new, RECLN, "%s*%s", base, ldf->parm);
174 MODE mode_n;
175 f2c_type (new, &mode_n, NOARG, NOFUN);
176 norm_mode (&mode_n);
177 idf->mode.type = mode_n.type;
178 idf->mode.len = mode_n.len;
179 }
180 rc = scan (NULL);
181 } else if (rc == INT_NUMBER || EQUAL (length, "*")) {
182 RECORD new;
183 RECCLR (new);
184 snprintf (new, RECLN, "%s*%s", base, length);
185 MODE mode_n;
186 f2c_type (new, &mode_n, NOARG, NOFUN);
187 norm_mode (&mode_n);
188 idf->mode.type = mode_n.type;
189 idf->mode.len = mode_n.len;
190 rc = scan (NULL);
191 } else {
192 SYNTAX (810, name);
193 }
194 }
195 //
196 } else if (TOKEN ("/") && idf != NULL) {
197 get_init (idf, &mode);
198 rc = scan (NULL);
199 if (!TOKEN ("/")) {
200 EXPECT (811, "/");
201 }
202 rc = scan (NULL);
203 }
204 if (TOKEN (",")) {
205 rc = scan (NULL);
206 if (! WITHIN) {
207 SYNTAX (812, NULL);
208 }
209 } else {
210 if (rc != END_OF_LINE) {
211 SYNTAX (813, NULL);
212 rc = scan (NULL);
213 }
214 }
215 }
216 }
217
218 IDENT *extf_decl (char *name, MODE *mode)
219 {
220 IDENT *idf = impl_decl (name, mode);
221 if (idf->external) {
222 ERROR (814, "already set external", CID (idf));
223 } else if (idf->intrinsic) {
224 ERROR (815, "already set intrinsic", CID (idf));
225 } else {
226 idf->external = TRUE;
227 }
228 return idf;
229 }
230
231 static void externals (void)
232 {
233 int_4 rc;
234 while ((rc = scan (NULL)) != END_OF_LINE) {
235 if (TOKEN (",")) {
236 ;
237 } else if (rc == WORD) {
238 MODE mode;
239 extf_decl (curlex, &mode);
240 } else {
241 EXPECT (816, "subprogram name");
242 }
243 }
244 }
245
246 static void intrinsics (void)
247 {
248 int_4 rc;
249 while ((rc = scan (NULL)) != END_OF_LINE) {
250 if (TOKEN (",")) {
251 ;
252 } else if (!is_intrins (curlex)){
253 EXPECT (817, "intrinsic funcion name");
254 } else {
255 RECORD name;
256 bufcpy (name, curlex, RECLN);
257 IDENT *idf = add_local (name, NOTYPE, NOLEN, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
258 if (idf->external) {
259 ERROR (818, "already set external", CID (idf));
260 } else if (idf->intrinsic) {
261 ERROR (819, "already set intrinsic", CID (idf));
262 } else {
263 idf->intrinsic = TRUE;
264 }
265 }
266 }
267 }
268
269 void get_decls (void)
270 {
271 int_4 go_on = TRUE;
272 idfs_reset ();
273 while (go_on) {
274 SAVE_POS;
275 int_4 rc = scan (NULL);
276 if (rc == DECLAR) {
277 dec_local ();
278 skip_card ();
279 } else if (TOKEN ("implicit")) {
280 skip_card ();
281 } else if (TOKEN ("save")) {
282 skip_card ();
283 } else if (TOKEN ("automatic")) {
284 skip_card ();
285 } else if (TOKEN ("parameter")) {
286 parameter ();
287 skip_card ();
288 } else if (TOKEN ("common")) {
289 common ();
290 skip_card ();
291 } else if (TOKEN ("dimension")) {
292 dimension ();
293 skip_card ();
294 } else if (TOKEN ("equivalence")) {
295 skip_card ();
296 } else if (TOKEN ("external")) {
297 externals ();
298 } else if (TOKEN ("intrinsic")) {
299 intrinsics ();
300 } else if (TOKEN ("data")) {
301 skip_card ();
302 } else if (strlen (curlex) > 0) {
303 // Backspace and done.
304 RESTORE_POS;
305 go_on = FALSE;
306 }
307 }
308 idfs_impl ();
309 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
