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 (1901, "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 (1902, "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, nest = 0;
88 RECORD mode;
89 RECCLR (mode);
90 while ((rc = scan (EXPECT_NONE)) != END_OF_LINE) {
91 if (TOKEN ("none")) {
92 for (k = ord ('a'); k <= ord ('z'); k++) {
93 f2c_type ("none", &(implic[k].mode), NOARG, NOFUN);
94 }
95 } else if (rc == DECLAR) {
96 strcpy (mode, curlex);
97 } else if (TOKEN ("automatic")) {
98 strcpy (mode, curlex);
99 } else if (TOKEN ("(")) {
100 RECORD a, z;
101 RECCLR (a);
102 nest++;
103 do {
104 rc = scan (EXPECT_NONE);
105 if (rc != WORD || strlen (curlex) > 1) {
106 EXPECT (1903, "a-z");
107 return;
108 }
109 strcpy (a, curlex);
110 rc = scan (EXPECT_NONE);
111 if (TOKEN ("-")) {
112 rc = scan (EXPECT_NONE);
113 if (rc != WORD || strlen (curlex) > 1) {
114 EXPECT (1904, "a-z");
115 return;
116 }
117 strcpy (z, curlex);
118 for (k = ord (a[0]); k <= ord (z[0]); k++) {
119 if (EQUAL (mode, "automatic")) {
120 implic[k].mode.save = AUTOMATIC;
121 } else {
122 f2c_type (mode, &(implic[k].mode), NOARG, NOFUN);
123 }
124 }
125 } else {
126 UNSCAN;
127 k = ord (a[0]);
128 if (EQUAL (mode, "automatic")) {
129 implic[k].mode.save = AUTOMATIC;
130 } else {
131 f2c_type (mode, &(implic[k].mode), NOARG, NOFUN);
132 }
133 }
134 rc = scan (EXPECT_NONE);
135 } while (TOKEN (","));
136 if (TOKEN (")")) {
137 UNSCAN;
138 }
139 } else if (TOKEN (")")) {
140 nest--;
141 } else if (TOKEN (",")) {
142 continue;
143 }
144 }
145 if (nest != 0) {
146 SYNTAX (1905, "parenthesis nesting");
147 }
148 }
149
150 void get_impl (void)
151 {
152 int_4 go_on = TRUE;
153 default_impl ();
154 while (go_on) {
155 SAVE_POS;
156 int_4 rc = scan (EXPECT_NONE);
157 if (rc == DECLAR) {
158 skip_card (FALSE);
159 } else if (TOKEN ("implicit")) {
160 implicit ();
161 skip_card (FALSE);
162 } else if (TOKEN ("save")) {
163 skip_card (FALSE);
164 } else if (TOKEN ("automatic")) {
165 skip_card (FALSE);
166 } else if (TOKEN ("parameter")) {
167 skip_card (FALSE);
168 } else if (TOKEN ("common")) {
169 skip_card (FALSE);
170 } else if (TOKEN ("dimension")) {
171 skip_card (FALSE);
172 } else if (TOKEN ("equivalence")) {
173 skip_card (FALSE);
174 } else if (TOKEN ("external")) {
175 skip_card (FALSE);
176 } else if (TOKEN ("intrinsic")) {
177 skip_card (FALSE);
178 } else if (TOKEN ("data")) {
179 skip_card (FALSE);
180 } else if (strlen (curlex) > 0) {
181 // Backspace and done.
182 RESTORE_POS;
183 go_on = FALSE;
184 }
185 }
186 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
