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