implicit.c
1 //! @file implicit.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 //! IMPLICIT declaration routines.
25
26 #include <vif.h>
27
28 IDENT *impl_decl (char *name, MODE * mode)
29 {
30 // This routine is called with a subexpression as 'name'.
31 //
32 // Filter commons, arguments and equivalences.
33 if (strchr (name, '.') != NO_TEXT) {
34 return NO_IDENT;
35 }
36 if (strstr (name, "->") != NO_TEXT) {
37 return NO_IDENT;
38 }
39 if (strchr (name, '*') != NO_TEXT) {
40 return NO_IDENT;
41 }
42 if (!IS_VAR (name)) {
43 ERROR (2201, "not a variable name", curlex);
44 return NO_IDENT;
45 }
46 // Apparently a normal local variable.
47 IDENT *idf = find_local (name, mode);
48 if (idf != NO_IDENT) {
49 if (idf->mode.type == NOTYPE) {
50 impl_type (name, &idf->mode);
51 }
52 } else {
53 if (nlocals >= MAX_IDENTS) {
54 FATAL (2202, "too many identifiers", NO_TEXT);
55 return NO_IDENT;
56 }
57 idf = &locals[nlocals++];
58 memset (idf, 0, sizeof (IDENT));
59 idf->line = curlin;
60 C_NAME (idf) = c_name (name);
61 FTN_NAME (idf) = f_stralloc (name);
62 idf->external = FALSE;
63 impl_type (name, &idf->mode);
64 if (mode != NO_MODE) {
65 *mode = idf->mode;
66 }
67 }
68 return idf;
69 }
70
71 void idfs_impl (void)
72 {
73 // Implicit-type remaining stuff
74 int_4 k;
75 for (k = 0; k < nlocals; k++) {
76 IDENT *idf = &locals[k];
77 if (idf->mode.type == NOTYPE && !idf->external) {
78 int_4 dim = idf->mode.dim;
79 impl_type (C_NAME (idf), &(idf->mode));
80 idf->mode.dim = dim;
81 }
82 }
83 }
84
85 void implicit (void)
86 {
87 int_4 k, rc, set = 0, nest = 0;
88 NEW_RECORD (mode);
89 while ((rc = scan (EXPECT_NONE)) != END_OF_LINE) {
90 if (TOKEN ("none")) {
91 for (k = ord ('a'); k <= ord ('z'); k++) {
92 f2c_type ("none", &(implic[k].mode), NOARG, NOFUN);
93 set++;
94 }
95 } else if (rc == DECLAR) {
96 RECCPY (mode, curlex);
97 } else if (TOKEN ("automatic")) {
98 RECCPY (mode, curlex);
99 } else if (TOKEN ("save")) {
100 RECCPY (mode, curlex);
101 } else if (TOKEN ("undefined")) {
102 RECCPY (mode, curlex);
103 } else if (TOKEN ("(") && strlen (mode) > 0) {
104 NEW_RECORD (a);
105 NEW_RECORD (z);
106 nest++;
107 do {
108 rc = scan (EXPECT_NONE);
109 if (rc != WORD || strlen (curlex) > 1) {
110 EXPECT (2203, "a-z");
111 return;
112 }
113 RECCPY (a, curlex);
114 rc = scan (EXPECT_NONE);
115 if (TOKEN ("-")) {
116 rc = scan (EXPECT_NONE);
117 if (rc != WORD || strlen (curlex) > 1) {
118 EXPECT (2204, "character range");
119 return;
120 }
121 RECCPY (z, curlex);
122 for (k = ord (a[0]); k <= ord (z[0]); k++) {
123 if (EQUAL (mode, "automatic")) {
124 implic[k].mode.save = AUTOMATIC;
125 } else if (EQUAL (mode, "save")) {
126 implic[k].mode.save = STATIC;
127 } else if (EQUAL (mode, "undefined")) {
128 f2c_type ("none", &(implic[k].mode), NOARG, NOFUN);
129 } else {
130 f2c_type (mode, &(implic[k].mode), NOARG, NOFUN);
131 }
132 }
133 set++;
134 } else {
135 UNSCAN;
136 k = ord (a[0]);
137 if (EQUAL (mode, "automatic")) {
138 implic[k].mode.save = AUTOMATIC;
139 } else if (EQUAL (mode, "save")) {
140 implic[k].mode.save = STATIC;
141 } else if (EQUAL (mode, "undefined")) {
142 f2c_type ("none", &(implic[k].mode), NOARG, NOFUN);
143 } else {
144 f2c_type (mode, &(implic[k].mode), NOARG, NOFUN);
145 }
146 set++;
147 }
148 rc = scan (EXPECT_NONE);
149 } while (TOKEN (","));
150 if (TOKEN (")")) {
151 UNSCAN;
152 }
153 } else if (TOKEN (")")) {
154 nest--;
155 } else if (TOKEN (",")) {
156 continue;
157 } else {
158 SYNTAX (2205, "implicit statement");
159 }
160 }
161 if (set == 0) {
162 SYNTAX (2206, "implicit statement");
163 }
164 if (nest != 0) {
165 SYNTAX (2207, "parenthesis nesting");
166 }
167 }
168
169 void get_impl (void)
170 {
171 int_4 go_on = TRUE;
172 default_impl ();
173 while (go_on) {
174 SAVE_POS (1);
175 int_4 rc = scan (EXPECT_NONE);
176 if (rc == DECLAR) {
177 skip_card (FALSE);
178 } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
179 implicit ();
180 skip_card (FALSE);
181 } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
182 skip_card (FALSE);
183 } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
184 skip_card (FALSE);
185 } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
186 skip_card (FALSE);
187 } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
188 skip_card (FALSE);
189 } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
190 skip_card (FALSE);
191 } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
192 skip_card (FALSE);
193 } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
194 skip_card (FALSE);
195 } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
196 skip_card (FALSE);
197 } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
198 skip_card (FALSE);
199 } else if (rc == WORD && IS_MACRO_DECLARATION) {
200 skip_card (FALSE);
201 } else if (strlen (curlex) > 0) {
202 // Backspace and done.
203 RESTORE_POS (1);
204 go_on = FALSE;
205 }
206 }
207 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
