1 /* implic.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 2002 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 Related Modules:
23 None.
24
25 Description:
26 The GNU Fortran Front End.
27
28 Modifications:
29 */
30
31 /* Include files. */
32
33 #include "proj.h"
34 #include "implic.h"
35 #include "info.h"
36 #include "src.h"
37 #include "symbol.h"
38 #include "target.h"
39
40 /* Externals defined here. */
41
42
43 /* Simple definitions and enumerations. */
44
45 typedef enum
46 {
47 FFEIMPLIC_stateINITIAL_,
48 FFEIMPLIC_stateASSUMED_,
49 FFEIMPLIC_stateESTABLISHED_,
50 FFEIMPLIC_state
51 } ffeimplicState_;
52
53 /* Internal typedefs. */
54
55 typedef struct _ffeimplic_ *ffeimplic_;
56
57 /* Private include files. */
58
59
60 /* Internal structure definitions. */
61
62 struct _ffeimplic_
63 {
64 ffeimplicState_ state;
65 ffeinfo info;
66 };
67
68 /* Static objects accessed by functions in this module. */
69
70 /* NOTE: This is definitely ASCII-specific!! */
71
72 static struct _ffeimplic_ ffeimplic_table_['z' - 'A' + 1];
73
74 /* Static functions (internal). */
75
76 static ffeimplic_ ffeimplic_lookup_ (unsigned char c);
77
78 /* Internal macros. */
79
80
81 /* ffeimplic_lookup_ -- Look up implicit descriptor for initial character
82
83 ffeimplic_ imp;
84 if ((imp = ffeimplic_lookup_('A')) == NULL)
85 // error
86
87 Returns a pointer to an implicit descriptor block based on the character
88 passed, or NULL if it is not a valid initial character for an implicit
89 data type. */
90
91 static ffeimplic_
ffeimplic_lookup_(unsigned char c)92 ffeimplic_lookup_ (unsigned char c)
93 {
94 /* NOTE: This is definitely ASCII-specific!! */
95 if (ISIDST (c))
96 return &ffeimplic_table_[c - 'A'];
97 return NULL;
98 }
99
100 /* ffeimplic_establish_initial -- Establish type of implicit initial letter
101
102 ffesymbol s;
103 if (!ffeimplic_establish_initial(s))
104 // error
105
106 Assigns implicit type information to the symbol based on the first
107 character of the symbol's name. */
108
109 bool
ffeimplic_establish_initial(char c,ffeinfoBasictype basic_type,ffeinfoKindtype kind_type,ffetargetCharacterSize size)110 ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type,
111 ffeinfoKindtype kind_type, ffetargetCharacterSize size)
112 {
113 ffeimplic_ imp;
114
115 imp = ffeimplic_lookup_ (c);
116 if (imp == NULL)
117 return FALSE; /* Character not A-Z or some such thing. */
118 if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
119 return FALSE; /* IMPLICIT NONE in effect here. */
120
121 switch (imp->state)
122 {
123 case FFEIMPLIC_stateINITIAL_:
124 imp->info = ffeinfo_new (basic_type,
125 kind_type,
126 0,
127 FFEINFO_kindNONE,
128 FFEINFO_whereNONE,
129 size);
130 imp->state = FFEIMPLIC_stateESTABLISHED_;
131 return TRUE;
132
133 case FFEIMPLIC_stateASSUMED_:
134 if ((ffeinfo_basictype (imp->info) != basic_type)
135 || (ffeinfo_kindtype (imp->info) != kind_type)
136 || (ffeinfo_size (imp->info) != size))
137 return FALSE;
138 imp->state = FFEIMPLIC_stateESTABLISHED_;
139 return TRUE;
140
141 case FFEIMPLIC_stateESTABLISHED_:
142 return FALSE;
143
144 default:
145 assert ("Weird state for implicit object" == NULL);
146 return FALSE;
147 }
148 }
149
150 /* ffeimplic_establish_symbol -- Establish implicit type of a symbol
151
152 ffesymbol s;
153 if (!ffeimplic_establish_symbol(s))
154 // error
155
156 Assigns implicit type information to the symbol based on the first
157 character of the symbol's name.
158
159 If symbol already has a type, return TRUE.
160 Get first character of symbol's name.
161 Get ffeimplic_ object for it (return FALSE if NULL returned).
162 Return FALSE if object has no assigned type (IMPLICIT NONE).
163 Copy the type information from the object to the symbol.
164 If the object is state "INITIAL", set to state "ASSUMED" so no
165 subsequent IMPLICIT statement may change the state.
166 Return TRUE. */
167
168 bool
ffeimplic_establish_symbol(ffesymbol s)169 ffeimplic_establish_symbol (ffesymbol s)
170 {
171 char c;
172 ffeimplic_ imp;
173
174 if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
175 return TRUE;
176
177 c = *(ffesymbol_text (s));
178 imp = ffeimplic_lookup_ (c);
179 if (imp == NULL)
180 return FALSE; /* First character not A-Z or some such
181 thing. */
182 if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
183 return FALSE; /* IMPLICIT NONE in effect here. */
184
185 ffesymbol_signal_change (s); /* Gonna change, save existing? */
186
187 /* Establish basictype, kindtype, size; preserve rank, kind, where. */
188
189 ffesymbol_set_info (s,
190 ffeinfo_new (ffeinfo_basictype (imp->info),
191 ffeinfo_kindtype (imp->info),
192 ffesymbol_rank (s),
193 ffesymbol_kind (s),
194 ffesymbol_where (s),
195 ffeinfo_size (imp->info)));
196
197 if (imp->state == FFEIMPLIC_stateINITIAL_)
198 imp->state = FFEIMPLIC_stateASSUMED_;
199
200 if (ffe_is_warn_implicit ())
201 {
202 /* xgettext:no-c-format */
203 ffebad_start_msg ("Implicit declaration of `%A' at %0",
204 FFEBAD_severityWARNING);
205 ffebad_here (0, ffesymbol_where_line (s),
206 ffesymbol_where_column (s));
207 ffebad_string (ffesymbol_text (s));
208 ffebad_finish ();
209 }
210
211 return TRUE;
212 }
213
214 /* ffeimplic_init_2 -- Initialize table
215
216 ffeimplic_init_2();
217
218 Assigns initial type information to all initial letters.
219
220 Allows for holes in the sequence of letters (i.e. EBCDIC). */
221
222 void
ffeimplic_init_2()223 ffeimplic_init_2 ()
224 {
225 ffeimplic_ imp;
226 char c;
227
228 for (c = 'A'; c <= 'z'; ++c)
229 {
230 imp = &ffeimplic_table_[c - 'A'];
231 imp->state = FFEIMPLIC_stateINITIAL_;
232 switch (c)
233 {
234 case 'A':
235 case 'B':
236 case 'C':
237 case 'D':
238 case 'E':
239 case 'F':
240 case 'G':
241 case 'H':
242 case 'O':
243 case 'P':
244 case 'Q':
245 case 'R':
246 case 'S':
247 case 'T':
248 case 'U':
249 case 'V':
250 case 'W':
251 case 'X':
252 case 'Y':
253 case 'Z':
254 case '_':
255 case 'a':
256 case 'b':
257 case 'c':
258 case 'd':
259 case 'e':
260 case 'f':
261 case 'g':
262 case 'h':
263 case 'o':
264 case 'p':
265 case 'q':
266 case 'r':
267 case 's':
268 case 't':
269 case 'u':
270 case 'v':
271 case 'w':
272 case 'x':
273 case 'y':
274 case 'z':
275 imp->info = ffeinfo_new (FFEINFO_basictypeREAL,
276 FFEINFO_kindtypeREALDEFAULT,
277 0,
278 FFEINFO_kindNONE,
279 FFEINFO_whereNONE,
280 FFETARGET_charactersizeNONE);
281 break;
282
283 case 'I':
284 case 'J':
285 case 'K':
286 case 'L':
287 case 'M':
288 case 'N':
289 case 'i':
290 case 'j':
291 case 'k':
292 case 'l':
293 case 'm':
294 case 'n':
295 imp->info = ffeinfo_new (FFEINFO_basictypeINTEGER,
296 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindNONE, FFEINFO_whereNONE,
297 FFETARGET_charactersizeNONE);
298 break;
299
300 default:
301 imp->info = ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0,
302 FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE);
303 break;
304 }
305 }
306 }
307
308 /* ffeimplic_none -- Implement IMPLICIT NONE statement
309
310 ffeimplic_none();
311
312 Assigns null type information to all initial letters. */
313
314 void
ffeimplic_none()315 ffeimplic_none ()
316 {
317 ffeimplic_ imp;
318
319 for (imp = &ffeimplic_table_[0];
320 imp != &ffeimplic_table_[ARRAY_SIZE (ffeimplic_table_)];
321 imp++)
322 {
323 imp->info = ffeinfo_new (FFEINFO_basictypeNONE,
324 FFEINFO_kindtypeNONE,
325 0,
326 FFEINFO_kindNONE,
327 FFEINFO_whereNONE,
328 FFETARGET_charactersizeNONE);
329 }
330 }
331
332 /* ffeimplic_peek_symbol_type -- Determine implicit type of a symbol
333
334 ffesymbol s;
335 const char *name; // name for s in case it is NULL, or NULL if s never NULL
336 if (ffeimplic_peek_symbol_type(s,name) == FFEINFO_basictypeCHARACTER)
337 // is or will be a CHARACTER-typed name
338
339 Like establish_symbol, but doesn't change anything.
340
341 If symbol is non-NULL and already has a type, return it.
342 Get first character of symbol's name or from name arg if symbol is NULL.
343 Get ffeimplic_ object for it (return FALSE if NULL returned).
344 Return NONE if object has no assigned type (IMPLICIT NONE).
345 Return the data type indicated in the object.
346
347 24-Oct-91 JCB 2.0
348 Take a char * instead of ffelexToken, since the latter isn't always
349 needed anyway (as when ffecom calls it). */
350
351 ffeinfoBasictype
ffeimplic_peek_symbol_type(ffesymbol s,const char * name)352 ffeimplic_peek_symbol_type (ffesymbol s, const char *name)
353 {
354 char c;
355 ffeimplic_ imp;
356
357 if (s == NULL)
358 c = *name;
359 else
360 {
361 if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
362 return ffesymbol_basictype (s);
363
364 c = *(ffesymbol_text (s));
365 }
366
367 imp = ffeimplic_lookup_ (c);
368 if (imp == NULL)
369 return FFEINFO_basictypeNONE; /* First character not A-Z or
370 something. */
371 return ffeinfo_basictype (imp->info);
372 }
373
374 /* ffeimplic_terminate_2 -- Terminate table
375
376 ffeimplic_terminate_2();
377
378 Kills info object for each entry in table. */
379
380 void
ffeimplic_terminate_2()381 ffeimplic_terminate_2 ()
382 {
383 }
384