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-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 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 == NO_TEXT && !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 (EXPECT_NONE);
57 factor (®);
58 if (accept_mode (reg.mode.type, reg.mode.len, mode->type, mode->len)) {
59 cpp_direct (nprocs, prelin, BODY);
60 NEW_RECORD (str);
61 if (mode->type == CHARACTER) {
62 _srecordf (str, "bufcpy (%s, %s, %d);\n", C_NAME (idf), reg.str, mode->len);
63 } else {
64 _srecordf (str, "%s = %s;\n", C_NAME (idf), reg.str);
65 }
66 code (nprocs, BODY, str);
67 } else {
68 ERROR (901, "expect type", qtype (mode));
69 }
70 }
71
72 void dec_local (void)
73 {
74 int_4 rc;
75 MODE mode;
76 NEW_RECORD (base);
77 RECCPY (base, curlex);
78 // Remove length specification.
79 char *star = strchr (base, '*');
80 if (star != NO_TEXT) {
81 *star = '\0';
82 }
83 //
84 f2c_type (curlex, &mode, NOARG, NOFUN);
85 rc = scan (EXPECT_NONE);
86 if (rc == END_OF_LINE) {
87 EXPECT (902, "identifier");
88 }
89 while (rc != END_OF_LINE) {
90 IDENT *idf = NO_IDENT;
91 // Identifier, store with leading mode unless length N is specified as idf*N.
92 NEW_RECORD (name);
93 if (rc != WORD) {
94 EXPECT (903, "identifier");
95 } else {
96 if (reserved (curlex)) {
97 ERROR (904, "reserved symbol", curlex);
98 }
99 RECCPY (name, curlex);
100 rc = scan (EXPECT_NONE);
101 if (!TOKEN ("*")) {
102 // identifier
103 idf = add_local (name, mode.type, mode.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
104 } else {
105 // identifier*length
106 NEW_RECORD (length);
107 rc = scan (EXPECT_NONE);
108 bufcpy (length, curlex, RECLN);
109 if (TOKEN ("(")) {
110 // identifier*(length)
111 rc = scan (EXPECT_NONE);
112 bufcpy (length, curlex, RECLN);
113 (void) scan (")");
114 }
115 if (rc == WORD) {
116 IDENT *ldf = find_local (length, NO_MODE);
117 if (ldf == NO_IDENT || ldf->parm == NO_TEXT) {
118 SYNTAX (905, length);
119 } else if (ldf->mode.type != INTEGER) {
120 EXPECT (906, "integer");
121 } else {
122 NEW_RECORD (new);
123 snprintf (new, RECLN, "%s*%s", base, ldf->parm);
124 MODE mode_n;
125 f2c_type (new, &mode_n, NOARG, NOFUN);
126 norm_mode (&mode_n);
127 idf = add_local (name, mode_n.type, mode_n.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
128 }
129 rc = scan (EXPECT_NONE);
130 } else if (rc == INT_NUMBER || EQUAL (length, "*")) {
131 NEW_RECORD (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 (EXPECT_NONE);
142 } else {
143 SYNTAX (907, name);
144 }
145 }
146 //
147 }
148 if (TOKEN ("(") && idf != NO_IDENT) {
149 if (IS_ROW (idf->mode)) {
150 ERROR (908, "already dimensioned", C_NAME (idf));
151 }
152 get_dims (idf, 1);
153 rc = scan (EXPECT_NONE);
154 if (TOKEN ("*")) {
155 NEW_RECORD (length);
156 rc = scan (EXPECT_NONE);
157 bufcpy (length, curlex, RECLN);
158 if (TOKEN ("(")) {
159 // identifier*(length)
160 rc = scan (EXPECT_NONE);
161 bufcpy (length, curlex, RECLN);
162 (void) scan (")");
163 }
164 if (rc == WORD) {
165 IDENT *ldf = find_local (length, NO_MODE);
166 if (ldf == NO_IDENT || ldf->parm == NO_TEXT) {
167 SYNTAX (909, length);
168 } else if (ldf->mode.type != INTEGER) {
169 EXPECT (910, "integer");
170 } else {
171 NEW_RECORD (new);
172 snprintf (new, RECLN, "%s*%s", base, ldf->parm);
173 MODE mode_n;
174 f2c_type (new, &mode_n, NOARG, NOFUN);
175 norm_mode (&mode_n);
176 idf->mode.type = mode_n.type;
177 idf->mode.len = mode_n.len;
178 }
179 rc = scan (EXPECT_NONE);
180 } else if (rc == INT_NUMBER || EQUAL (length, "*")) {
181 NEW_RECORD (new);
182 snprintf (new, RECLN, "%s*%s", base, length);
183 MODE mode_n;
184 f2c_type (new, &mode_n, NOARG, NOFUN);
185 norm_mode (&mode_n);
186 idf->mode.type = mode_n.type;
187 idf->mode.len = mode_n.len;
188 rc = scan (EXPECT_NONE);
189 } else {
190 SYNTAX (911, name);
191 }
192 }
193 //
194 } else if (TOKEN ("/") && idf != NO_IDENT) {
195 get_init (idf, &mode);
196 rc = scan (EXPECT_NONE);
197 if (!TOKEN ("/")) {
198 EXPECT (912, "/");
199 }
200 rc = scan (EXPECT_NONE);
201 }
202 if (TOKEN (",")) {
203 rc = scan (EXPECT_NONE);
204 if (! WITHIN) {
205 SYNTAX (913, NO_TEXT);
206 }
207 } else {
208 if (rc != END_OF_LINE) {
209 SYNTAX (914, NO_TEXT);
210 rc = scan (EXPECT_NONE);
211 }
212 }
213 }
214 }
215
216 IDENT *extf_decl (char *name, MODE *mode)
217 {
218 IDENT *idf = impl_decl (name, mode);
219 if (idf->external) {
220 ERROR (915, "already set external", C_NAME (idf));
221 } else if (idf->intrinsic) {
222 ERROR (916, "already set intrinsic", C_NAME (idf));
223 } else {
224 idf->external = TRUE;
225 }
226 return idf;
227 }
228
229 void get_decls (void)
230 {
231 int_4 go_on = TRUE;
232 idfs_reset ();
233 while (go_on) {
234 SAVE_POS;
235 int_4 rc = scan (EXPECT_NONE);
236 if (rc == DECLAR) {
237 dec_local ();
238 skip_card (FALSE);
239 } else if (TOKEN ("implicit")) {
240 skip_card (FALSE);
241 } else if (TOKEN ("save")) {
242 skip_card (FALSE);
243 } else if (TOKEN ("automatic")) {
244 skip_card (FALSE);
245 } else if (TOKEN ("parameter")) {
246 parameter ();
247 skip_card (FALSE);
248 } else if (TOKEN ("common")) {
249 common ();
250 skip_card (FALSE);
251 } else if (TOKEN ("dimension")) {
252 dimension ();
253 skip_card (FALSE);
254 } else if (TOKEN ("equivalence")) {
255 skip_card (FALSE);
256 } else if (TOKEN ("external")) {
257 externals ();
258 } else if (TOKEN ("intrinsic")) {
259 intrinsics ();
260 } else if (TOKEN ("data")) {
261 skip_card (FALSE);
262 } else if (rc == WORD && is_macro_decl (curlex)) {
263 skip_card (FALSE);
264 } else if (strlen (curlex) > 0) {
265 // Backspace and done.
266 RESTORE_POS;
267 go_on = FALSE;
268 }
269 }
270 idfs_impl ();
271 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
