1*c87b03e5Sespie /* global.c -- Implementation File (module.c template V1.0)
2*c87b03e5Sespie Copyright (C) 1995, 1997 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
24*c87b03e5Sespie Description:
25*c87b03e5Sespie Manages information kept across individual program units within a single
26*c87b03e5Sespie source file. This includes reporting errors when a name is defined
27*c87b03e5Sespie multiple times (for example, two program units named FOO) and when a
28*c87b03e5Sespie COMMON block is given initial data in more than one program unit.
29*c87b03e5Sespie
30*c87b03e5Sespie Modifications:
31*c87b03e5Sespie */
32*c87b03e5Sespie
33*c87b03e5Sespie /* Include files. */
34*c87b03e5Sespie
35*c87b03e5Sespie #include "proj.h"
36*c87b03e5Sespie #include "global.h"
37*c87b03e5Sespie #include "info.h"
38*c87b03e5Sespie #include "lex.h"
39*c87b03e5Sespie #include "malloc.h"
40*c87b03e5Sespie #include "name.h"
41*c87b03e5Sespie #include "symbol.h"
42*c87b03e5Sespie #include "top.h"
43*c87b03e5Sespie
44*c87b03e5Sespie /* Externals defined here. */
45*c87b03e5Sespie
46*c87b03e5Sespie
47*c87b03e5Sespie /* Simple definitions and enumerations. */
48*c87b03e5Sespie
49*c87b03e5Sespie
50*c87b03e5Sespie /* Internal typedefs. */
51*c87b03e5Sespie
52*c87b03e5Sespie
53*c87b03e5Sespie /* Private include files. */
54*c87b03e5Sespie
55*c87b03e5Sespie
56*c87b03e5Sespie /* Internal structure definitions. */
57*c87b03e5Sespie
58*c87b03e5Sespie
59*c87b03e5Sespie /* Static objects accessed by functions in this module. */
60*c87b03e5Sespie
61*c87b03e5Sespie #if FFEGLOBAL_ENABLED
62*c87b03e5Sespie static ffenameSpace ffeglobal_filewide_ = NULL;
63*c87b03e5Sespie static const char *const ffeglobal_type_string_[] =
64*c87b03e5Sespie {
65*c87b03e5Sespie [FFEGLOBAL_typeNONE] "??",
66*c87b03e5Sespie [FFEGLOBAL_typeMAIN] "main program",
67*c87b03e5Sespie [FFEGLOBAL_typeEXT] "external",
68*c87b03e5Sespie [FFEGLOBAL_typeSUBR] "subroutine",
69*c87b03e5Sespie [FFEGLOBAL_typeFUNC] "function",
70*c87b03e5Sespie [FFEGLOBAL_typeBDATA] "block data",
71*c87b03e5Sespie [FFEGLOBAL_typeCOMMON] "common block",
72*c87b03e5Sespie [FFEGLOBAL_typeANY] "?any?"
73*c87b03e5Sespie };
74*c87b03e5Sespie #endif
75*c87b03e5Sespie
76*c87b03e5Sespie /* Static functions (internal). */
77*c87b03e5Sespie
78*c87b03e5Sespie
79*c87b03e5Sespie /* Internal macros. */
80*c87b03e5Sespie
81*c87b03e5Sespie
82*c87b03e5Sespie /* Call given fn with all globals
83*c87b03e5Sespie
84*c87b03e5Sespie ffeglobal (*fn)(ffeglobal g);
85*c87b03e5Sespie ffeglobal_drive(fn); */
86*c87b03e5Sespie
87*c87b03e5Sespie #if FFEGLOBAL_ENABLED
88*c87b03e5Sespie void
ffeglobal_drive(ffeglobal (* fn)(ffeglobal))89*c87b03e5Sespie ffeglobal_drive (ffeglobal (*fn) (ffeglobal))
90*c87b03e5Sespie {
91*c87b03e5Sespie if (ffeglobal_filewide_ != NULL)
92*c87b03e5Sespie ffename_space_drive_global (ffeglobal_filewide_, fn);
93*c87b03e5Sespie }
94*c87b03e5Sespie
95*c87b03e5Sespie #endif
96*c87b03e5Sespie /* ffeglobal_new_ -- Make new global
97*c87b03e5Sespie
98*c87b03e5Sespie ffename n;
99*c87b03e5Sespie ffeglobal g;
100*c87b03e5Sespie g = ffeglobal_new_(n); */
101*c87b03e5Sespie
102*c87b03e5Sespie #if FFEGLOBAL_ENABLED
103*c87b03e5Sespie static ffeglobal
ffeglobal_new_(ffename n)104*c87b03e5Sespie ffeglobal_new_ (ffename n)
105*c87b03e5Sespie {
106*c87b03e5Sespie ffeglobal g;
107*c87b03e5Sespie
108*c87b03e5Sespie assert (n != NULL);
109*c87b03e5Sespie
110*c87b03e5Sespie g = (ffeglobal) malloc_new_ks (malloc_pool_image (), "FFEGLOBAL",
111*c87b03e5Sespie sizeof (*g));
112*c87b03e5Sespie g->n = n;
113*c87b03e5Sespie #ifdef FFECOM_globalHOOK
114*c87b03e5Sespie g->hook = FFECOM_globalNULL;
115*c87b03e5Sespie #endif
116*c87b03e5Sespie g->tick = 0;
117*c87b03e5Sespie
118*c87b03e5Sespie ffename_set_global (n, g);
119*c87b03e5Sespie
120*c87b03e5Sespie return g;
121*c87b03e5Sespie }
122*c87b03e5Sespie
123*c87b03e5Sespie #endif
124*c87b03e5Sespie /* ffeglobal_init_1 -- Initialize per file
125*c87b03e5Sespie
126*c87b03e5Sespie ffeglobal_init_1(); */
127*c87b03e5Sespie
128*c87b03e5Sespie void
ffeglobal_init_1()129*c87b03e5Sespie ffeglobal_init_1 ()
130*c87b03e5Sespie {
131*c87b03e5Sespie #if FFEGLOBAL_ENABLED
132*c87b03e5Sespie if (ffeglobal_filewide_ != NULL)
133*c87b03e5Sespie ffename_space_kill (ffeglobal_filewide_);
134*c87b03e5Sespie ffeglobal_filewide_ = ffename_space_new (malloc_pool_image ());
135*c87b03e5Sespie #endif
136*c87b03e5Sespie }
137*c87b03e5Sespie
138*c87b03e5Sespie /* ffeglobal_init_common -- Initial value specified for common block
139*c87b03e5Sespie
140*c87b03e5Sespie ffesymbol s; // the ffesymbol for the common block
141*c87b03e5Sespie ffelexToken t; // the token with the point of initialization
142*c87b03e5Sespie ffeglobal_init_common(s,t);
143*c87b03e5Sespie
144*c87b03e5Sespie For back ends where file-wide global symbols are not maintained, does
145*c87b03e5Sespie nothing. Otherwise, makes sure this common block hasn't already been
146*c87b03e5Sespie initialized in a previous program unit, and flag that it's been
147*c87b03e5Sespie initialized in this one. */
148*c87b03e5Sespie
149*c87b03e5Sespie void
ffeglobal_init_common(ffesymbol s,ffelexToken t)150*c87b03e5Sespie ffeglobal_init_common (ffesymbol s, ffelexToken t)
151*c87b03e5Sespie {
152*c87b03e5Sespie #if FFEGLOBAL_ENABLED
153*c87b03e5Sespie ffeglobal g;
154*c87b03e5Sespie
155*c87b03e5Sespie g = ffesymbol_global (s);
156*c87b03e5Sespie
157*c87b03e5Sespie if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
158*c87b03e5Sespie return;
159*c87b03e5Sespie if (g->type == FFEGLOBAL_typeANY)
160*c87b03e5Sespie return;
161*c87b03e5Sespie
162*c87b03e5Sespie if (g->tick == ffe_count_2)
163*c87b03e5Sespie return;
164*c87b03e5Sespie
165*c87b03e5Sespie if (g->tick != 0)
166*c87b03e5Sespie {
167*c87b03e5Sespie if (g->u.common.initt != NULL)
168*c87b03e5Sespie {
169*c87b03e5Sespie ffebad_start (FFEBAD_COMMON_ALREADY_INIT);
170*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
171*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
172*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->u.common.initt),
173*c87b03e5Sespie ffelex_token_where_column (g->u.common.initt));
174*c87b03e5Sespie ffebad_finish ();
175*c87b03e5Sespie }
176*c87b03e5Sespie
177*c87b03e5Sespie /* Complain about just one attempt to reinit per program unit, but
178*c87b03e5Sespie continue referring back to the first such successful attempt. */
179*c87b03e5Sespie }
180*c87b03e5Sespie else
181*c87b03e5Sespie {
182*c87b03e5Sespie if (g->u.common.blank)
183*c87b03e5Sespie {
184*c87b03e5Sespie /* Not supposed to initialize blank common, though it works. */
185*c87b03e5Sespie ffebad_start (FFEBAD_COMMON_BLANK_INIT);
186*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
187*c87b03e5Sespie ffebad_finish ();
188*c87b03e5Sespie }
189*c87b03e5Sespie
190*c87b03e5Sespie g->u.common.initt = ffelex_token_use (t);
191*c87b03e5Sespie }
192*c87b03e5Sespie
193*c87b03e5Sespie g->tick = ffe_count_2;
194*c87b03e5Sespie #endif
195*c87b03e5Sespie }
196*c87b03e5Sespie
197*c87b03e5Sespie /* ffeglobal_new_common -- New common block
198*c87b03e5Sespie
199*c87b03e5Sespie ffesymbol s; // the ffesymbol for the new common block
200*c87b03e5Sespie ffelexToken t; // the token with the name of the common block
201*c87b03e5Sespie bool blank; // TRUE if blank common
202*c87b03e5Sespie ffeglobal_new_common(s,t,blank);
203*c87b03e5Sespie
204*c87b03e5Sespie For back ends where file-wide global symbols are not maintained, does
205*c87b03e5Sespie nothing. Otherwise, makes sure this symbol hasn't been seen before or
206*c87b03e5Sespie is known as a common block. */
207*c87b03e5Sespie
208*c87b03e5Sespie void
ffeglobal_new_common(ffesymbol s,ffelexToken t,bool blank)209*c87b03e5Sespie ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank)
210*c87b03e5Sespie {
211*c87b03e5Sespie #if FFEGLOBAL_ENABLED
212*c87b03e5Sespie ffename n;
213*c87b03e5Sespie ffeglobal g;
214*c87b03e5Sespie
215*c87b03e5Sespie if (ffesymbol_global (s) == NULL)
216*c87b03e5Sespie {
217*c87b03e5Sespie n = ffename_find (ffeglobal_filewide_, t);
218*c87b03e5Sespie g = ffename_global (n);
219*c87b03e5Sespie }
220*c87b03e5Sespie else
221*c87b03e5Sespie {
222*c87b03e5Sespie g = ffesymbol_global (s);
223*c87b03e5Sespie n = NULL;
224*c87b03e5Sespie }
225*c87b03e5Sespie
226*c87b03e5Sespie if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
227*c87b03e5Sespie return;
228*c87b03e5Sespie
229*c87b03e5Sespie if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
230*c87b03e5Sespie {
231*c87b03e5Sespie if (g->type == FFEGLOBAL_typeCOMMON)
232*c87b03e5Sespie {
233*c87b03e5Sespie /* The names match, so the "blankness" should match too! */
234*c87b03e5Sespie assert (g->u.common.blank == blank);
235*c87b03e5Sespie }
236*c87b03e5Sespie else
237*c87b03e5Sespie {
238*c87b03e5Sespie /* This global name has already been established,
239*c87b03e5Sespie but as something other than a common block. */
240*c87b03e5Sespie if (ffe_is_globals () || ffe_is_warn_globals ())
241*c87b03e5Sespie {
242*c87b03e5Sespie ffebad_start (ffe_is_globals ()
243*c87b03e5Sespie ? FFEBAD_FILEWIDE_ALREADY_SEEN
244*c87b03e5Sespie : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
245*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
246*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
247*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
248*c87b03e5Sespie ffelex_token_where_column (g->t));
249*c87b03e5Sespie ffebad_finish ();
250*c87b03e5Sespie }
251*c87b03e5Sespie g->type = FFEGLOBAL_typeANY;
252*c87b03e5Sespie }
253*c87b03e5Sespie }
254*c87b03e5Sespie else
255*c87b03e5Sespie {
256*c87b03e5Sespie if (g == NULL)
257*c87b03e5Sespie {
258*c87b03e5Sespie g = ffeglobal_new_ (n);
259*c87b03e5Sespie g->intrinsic = FALSE;
260*c87b03e5Sespie }
261*c87b03e5Sespie else if (g->intrinsic
262*c87b03e5Sespie && !g->explicit_intrinsic
263*c87b03e5Sespie && ffe_is_warn_globals ())
264*c87b03e5Sespie {
265*c87b03e5Sespie /* Common name previously used as intrinsic. Though it works,
266*c87b03e5Sespie warn, because the intrinsic reference might have been intended
267*c87b03e5Sespie as a ref to an external procedure, but g77's vast list of
268*c87b03e5Sespie intrinsics happened to snarf the name. */
269*c87b03e5Sespie ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
270*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
271*c87b03e5Sespie ffebad_string ("common block");
272*c87b03e5Sespie ffebad_string ("intrinsic");
273*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
274*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
275*c87b03e5Sespie ffelex_token_where_column (g->t));
276*c87b03e5Sespie ffebad_finish ();
277*c87b03e5Sespie }
278*c87b03e5Sespie g->t = ffelex_token_use (t);
279*c87b03e5Sespie g->type = FFEGLOBAL_typeCOMMON;
280*c87b03e5Sespie g->u.common.have_pad = FALSE;
281*c87b03e5Sespie g->u.common.have_save = FALSE;
282*c87b03e5Sespie g->u.common.have_size = FALSE;
283*c87b03e5Sespie g->u.common.blank = blank;
284*c87b03e5Sespie }
285*c87b03e5Sespie
286*c87b03e5Sespie ffesymbol_set_global (s, g);
287*c87b03e5Sespie #endif
288*c87b03e5Sespie }
289*c87b03e5Sespie
290*c87b03e5Sespie /* ffeglobal_new_progunit_ -- New program unit
291*c87b03e5Sespie
292*c87b03e5Sespie ffesymbol s; // the ffesymbol for the new unit
293*c87b03e5Sespie ffelexToken t; // the token with the name of the unit
294*c87b03e5Sespie ffeglobalType type; // the type of the new unit
295*c87b03e5Sespie ffeglobal_new_progunit_(s,t,type);
296*c87b03e5Sespie
297*c87b03e5Sespie For back ends where file-wide global symbols are not maintained, does
298*c87b03e5Sespie nothing. Otherwise, makes sure this symbol hasn't been seen before. */
299*c87b03e5Sespie
300*c87b03e5Sespie void
ffeglobal_new_progunit_(ffesymbol s,ffelexToken t,ffeglobalType type)301*c87b03e5Sespie ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
302*c87b03e5Sespie {
303*c87b03e5Sespie #if FFEGLOBAL_ENABLED
304*c87b03e5Sespie ffename n;
305*c87b03e5Sespie ffeglobal g;
306*c87b03e5Sespie
307*c87b03e5Sespie n = ffename_find (ffeglobal_filewide_, t);
308*c87b03e5Sespie g = ffename_global (n);
309*c87b03e5Sespie if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
310*c87b03e5Sespie return;
311*c87b03e5Sespie
312*c87b03e5Sespie if ((g != NULL)
313*c87b03e5Sespie && ((g->type == FFEGLOBAL_typeMAIN)
314*c87b03e5Sespie || (g->type == FFEGLOBAL_typeSUBR)
315*c87b03e5Sespie || (g->type == FFEGLOBAL_typeFUNC)
316*c87b03e5Sespie || (g->type == FFEGLOBAL_typeBDATA))
317*c87b03e5Sespie && g->u.proc.defined)
318*c87b03e5Sespie {
319*c87b03e5Sespie /* This program unit has already been defined. */
320*c87b03e5Sespie if (ffe_is_globals () || ffe_is_warn_globals ())
321*c87b03e5Sespie {
322*c87b03e5Sespie ffebad_start (ffe_is_globals ()
323*c87b03e5Sespie ? FFEBAD_FILEWIDE_ALREADY_SEEN
324*c87b03e5Sespie : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
325*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
326*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t),
327*c87b03e5Sespie ffelex_token_where_column (t));
328*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
329*c87b03e5Sespie ffelex_token_where_column (g->t));
330*c87b03e5Sespie ffebad_finish ();
331*c87b03e5Sespie }
332*c87b03e5Sespie g->type = FFEGLOBAL_typeANY;
333*c87b03e5Sespie }
334*c87b03e5Sespie else if ((g != NULL)
335*c87b03e5Sespie && (g->type != FFEGLOBAL_typeNONE)
336*c87b03e5Sespie && (g->type != FFEGLOBAL_typeEXT)
337*c87b03e5Sespie && (g->type != type))
338*c87b03e5Sespie {
339*c87b03e5Sespie /* A reference to this program unit has been seen, but its
340*c87b03e5Sespie context disagrees about the new definition regarding
341*c87b03e5Sespie what kind of program unit it is. (E.g. `call foo' followed
342*c87b03e5Sespie by `function foo'.) But `external foo' alone doesn't mean
343*c87b03e5Sespie disagreement with either a function or subroutine, though
344*c87b03e5Sespie g77 normally interprets it as a request to force-load
345*c87b03e5Sespie a block data program unit by that name (to cope with libs). */
346*c87b03e5Sespie if (ffe_is_globals () || ffe_is_warn_globals ())
347*c87b03e5Sespie {
348*c87b03e5Sespie ffebad_start (ffe_is_globals ()
349*c87b03e5Sespie ? FFEBAD_FILEWIDE_DISAGREEMENT
350*c87b03e5Sespie : FFEBAD_FILEWIDE_DISAGREEMENT_W);
351*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
352*c87b03e5Sespie ffebad_string (ffeglobal_type_string_[type]);
353*c87b03e5Sespie ffebad_string (ffeglobal_type_string_[g->type]);
354*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t),
355*c87b03e5Sespie ffelex_token_where_column (t));
356*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
357*c87b03e5Sespie ffelex_token_where_column (g->t));
358*c87b03e5Sespie ffebad_finish ();
359*c87b03e5Sespie }
360*c87b03e5Sespie g->type = FFEGLOBAL_typeANY;
361*c87b03e5Sespie }
362*c87b03e5Sespie else
363*c87b03e5Sespie {
364*c87b03e5Sespie if (g == NULL)
365*c87b03e5Sespie {
366*c87b03e5Sespie g = ffeglobal_new_ (n);
367*c87b03e5Sespie g->intrinsic = FALSE;
368*c87b03e5Sespie g->u.proc.n_args = -1;
369*c87b03e5Sespie g->u.proc.other_t = NULL;
370*c87b03e5Sespie }
371*c87b03e5Sespie else if ((ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
372*c87b03e5Sespie && (g->type == FFEGLOBAL_typeFUNC)
373*c87b03e5Sespie && ((ffesymbol_basictype (s) != g->u.proc.bt)
374*c87b03e5Sespie || (ffesymbol_kindtype (s) != g->u.proc.kt)
375*c87b03e5Sespie || ((ffesymbol_size (s) != FFETARGET_charactersizeNONE)
376*c87b03e5Sespie && (ffesymbol_size (s) != g->u.proc.sz))))
377*c87b03e5Sespie {
378*c87b03e5Sespie /* The previous reference and this new function definition
379*c87b03e5Sespie disagree about the type of the function. I (Burley) think
380*c87b03e5Sespie this rarely occurs, because when this code is reached,
381*c87b03e5Sespie the type info doesn't appear to be filled in yet. */
382*c87b03e5Sespie if (ffe_is_globals () || ffe_is_warn_globals ())
383*c87b03e5Sespie {
384*c87b03e5Sespie ffebad_start (ffe_is_globals ()
385*c87b03e5Sespie ? FFEBAD_FILEWIDE_TYPE_MISMATCH
386*c87b03e5Sespie : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
387*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
388*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t),
389*c87b03e5Sespie ffelex_token_where_column (t));
390*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
391*c87b03e5Sespie ffelex_token_where_column (g->t));
392*c87b03e5Sespie ffebad_finish ();
393*c87b03e5Sespie }
394*c87b03e5Sespie g->type = FFEGLOBAL_typeANY;
395*c87b03e5Sespie return;
396*c87b03e5Sespie }
397*c87b03e5Sespie if (g->intrinsic
398*c87b03e5Sespie && !g->explicit_intrinsic
399*c87b03e5Sespie && ffe_is_warn_globals ())
400*c87b03e5Sespie {
401*c87b03e5Sespie /* This name, previously used as an intrinsic, now is known
402*c87b03e5Sespie to also be a global procedure name. Warn, since the previous
403*c87b03e5Sespie use as an intrinsic might have been intended to refer to
404*c87b03e5Sespie this procedure. */
405*c87b03e5Sespie ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
406*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
407*c87b03e5Sespie ffebad_string ("global");
408*c87b03e5Sespie ffebad_string ("intrinsic");
409*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
410*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
411*c87b03e5Sespie ffelex_token_where_column (g->t));
412*c87b03e5Sespie ffebad_finish ();
413*c87b03e5Sespie }
414*c87b03e5Sespie g->t = ffelex_token_use (t);
415*c87b03e5Sespie if ((g->tick == 0)
416*c87b03e5Sespie || (g->u.proc.bt == FFEINFO_basictypeNONE)
417*c87b03e5Sespie || (g->u.proc.kt == FFEINFO_kindtypeNONE))
418*c87b03e5Sespie {
419*c87b03e5Sespie g->u.proc.bt = ffesymbol_basictype (s);
420*c87b03e5Sespie g->u.proc.kt = ffesymbol_kindtype (s);
421*c87b03e5Sespie g->u.proc.sz = ffesymbol_size (s);
422*c87b03e5Sespie }
423*c87b03e5Sespie /* If there's a known disagreement about the kind of program
424*c87b03e5Sespie unit, then don't even bother tracking arglist argreement. */
425*c87b03e5Sespie if ((g->tick != 0)
426*c87b03e5Sespie && (g->type != type))
427*c87b03e5Sespie g->u.proc.n_args = -1;
428*c87b03e5Sespie g->tick = ffe_count_2;
429*c87b03e5Sespie g->type = type;
430*c87b03e5Sespie g->u.proc.defined = TRUE;
431*c87b03e5Sespie }
432*c87b03e5Sespie
433*c87b03e5Sespie ffesymbol_set_global (s, g);
434*c87b03e5Sespie #endif
435*c87b03e5Sespie }
436*c87b03e5Sespie
437*c87b03e5Sespie /* ffeglobal_pad_common -- Check initial padding of common area
438*c87b03e5Sespie
439*c87b03e5Sespie ffesymbol s; // the common area
440*c87b03e5Sespie ffetargetAlign pad; // the initial padding
441*c87b03e5Sespie ffeglobal_pad_common(s,pad,ffesymbol_where_line(s),
442*c87b03e5Sespie ffesymbol_where_column(s));
443*c87b03e5Sespie
444*c87b03e5Sespie In global-enabled mode, make sure the padding agrees with any existing
445*c87b03e5Sespie padding established for the common area, otherwise complain.
446*c87b03e5Sespie In global-disabled mode, warn about nonzero padding. */
447*c87b03e5Sespie
448*c87b03e5Sespie void
ffeglobal_pad_common(ffesymbol s,ffetargetAlign pad,ffewhereLine wl,ffewhereColumn wc)449*c87b03e5Sespie ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl,
450*c87b03e5Sespie ffewhereColumn wc)
451*c87b03e5Sespie {
452*c87b03e5Sespie #if FFEGLOBAL_ENABLED
453*c87b03e5Sespie ffeglobal g;
454*c87b03e5Sespie
455*c87b03e5Sespie g = ffesymbol_global (s);
456*c87b03e5Sespie if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
457*c87b03e5Sespie return; /* Let someone else catch this! */
458*c87b03e5Sespie if (g->type == FFEGLOBAL_typeANY)
459*c87b03e5Sespie return;
460*c87b03e5Sespie
461*c87b03e5Sespie if (!g->u.common.have_pad)
462*c87b03e5Sespie {
463*c87b03e5Sespie g->u.common.have_pad = TRUE;
464*c87b03e5Sespie g->u.common.pad = pad;
465*c87b03e5Sespie g->u.common.pad_where_line = ffewhere_line_use (wl);
466*c87b03e5Sespie g->u.common.pad_where_col = ffewhere_column_use (wc);
467*c87b03e5Sespie
468*c87b03e5Sespie if (pad != 0)
469*c87b03e5Sespie {
470*c87b03e5Sespie char padding[20];
471*c87b03e5Sespie
472*c87b03e5Sespie sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
473*c87b03e5Sespie ffebad_start (FFEBAD_COMMON_INIT_PAD);
474*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
475*c87b03e5Sespie ffebad_string (padding);
476*c87b03e5Sespie ffebad_string ((pad == 1)
477*c87b03e5Sespie ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
478*c87b03e5Sespie ffebad_here (0, wl, wc);
479*c87b03e5Sespie ffebad_finish ();
480*c87b03e5Sespie }
481*c87b03e5Sespie }
482*c87b03e5Sespie else
483*c87b03e5Sespie {
484*c87b03e5Sespie if (g->u.common.pad != pad)
485*c87b03e5Sespie {
486*c87b03e5Sespie char padding_1[20];
487*c87b03e5Sespie char padding_2[20];
488*c87b03e5Sespie
489*c87b03e5Sespie sprintf (&padding_1[0], "%" ffetargetAlign_f "u", pad);
490*c87b03e5Sespie sprintf (&padding_2[0], "%" ffetargetAlign_f "u", g->u.common.pad);
491*c87b03e5Sespie ffebad_start (FFEBAD_COMMON_DIFF_PAD);
492*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
493*c87b03e5Sespie ffebad_string (padding_1);
494*c87b03e5Sespie ffebad_here (0, wl, wc);
495*c87b03e5Sespie ffebad_string (padding_2);
496*c87b03e5Sespie ffebad_string ((pad == 1)
497*c87b03e5Sespie ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
498*c87b03e5Sespie ffebad_string ((g->u.common.pad == 1)
499*c87b03e5Sespie ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
500*c87b03e5Sespie ffebad_here (1, g->u.common.pad_where_line, g->u.common.pad_where_col);
501*c87b03e5Sespie ffebad_finish ();
502*c87b03e5Sespie }
503*c87b03e5Sespie
504*c87b03e5Sespie if (g->u.common.pad < pad)
505*c87b03e5Sespie {
506*c87b03e5Sespie g->u.common.pad = pad;
507*c87b03e5Sespie g->u.common.pad_where_line = ffewhere_line_use (wl);
508*c87b03e5Sespie g->u.common.pad_where_col = ffewhere_column_use (wc);
509*c87b03e5Sespie }
510*c87b03e5Sespie }
511*c87b03e5Sespie #endif
512*c87b03e5Sespie }
513*c87b03e5Sespie
514*c87b03e5Sespie /* Collect info for a global's argument. */
515*c87b03e5Sespie
516*c87b03e5Sespie void
ffeglobal_proc_def_arg(ffesymbol s,int argno,const char * name,ffeglobalArgSummary as,ffeinfoBasictype bt,ffeinfoKindtype kt,bool array)517*c87b03e5Sespie ffeglobal_proc_def_arg (ffesymbol s, int argno, const char *name, ffeglobalArgSummary as,
518*c87b03e5Sespie ffeinfoBasictype bt, ffeinfoKindtype kt,
519*c87b03e5Sespie bool array)
520*c87b03e5Sespie {
521*c87b03e5Sespie ffeglobal g = ffesymbol_global (s);
522*c87b03e5Sespie ffeglobalArgInfo_ ai;
523*c87b03e5Sespie
524*c87b03e5Sespie assert (g != NULL);
525*c87b03e5Sespie
526*c87b03e5Sespie if (g->type == FFEGLOBAL_typeANY)
527*c87b03e5Sespie return;
528*c87b03e5Sespie
529*c87b03e5Sespie assert (g->u.proc.n_args >= 0);
530*c87b03e5Sespie
531*c87b03e5Sespie if (argno >= g->u.proc.n_args)
532*c87b03e5Sespie return; /* Already complained about this discrepancy. */
533*c87b03e5Sespie
534*c87b03e5Sespie ai = &g->u.proc.arg_info[argno];
535*c87b03e5Sespie
536*c87b03e5Sespie /* Maybe warn about previous references. */
537*c87b03e5Sespie
538*c87b03e5Sespie if ((ai->t != NULL)
539*c87b03e5Sespie && ffe_is_warn_globals ())
540*c87b03e5Sespie {
541*c87b03e5Sespie const char *refwhy = NULL;
542*c87b03e5Sespie const char *defwhy = NULL;
543*c87b03e5Sespie bool warn = FALSE;
544*c87b03e5Sespie
545*c87b03e5Sespie switch (as)
546*c87b03e5Sespie {
547*c87b03e5Sespie case FFEGLOBAL_argsummaryREF:
548*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryREF)
549*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE)
550*c87b03e5Sespie && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */
551*c87b03e5Sespie || (ai->bt != FFEINFO_basictypeCHARACTER)
552*c87b03e5Sespie || (ai->bt == bt)))
553*c87b03e5Sespie {
554*c87b03e5Sespie warn = TRUE;
555*c87b03e5Sespie refwhy = "passed by reference";
556*c87b03e5Sespie }
557*c87b03e5Sespie break;
558*c87b03e5Sespie
559*c87b03e5Sespie case FFEGLOBAL_argsummaryDESCR:
560*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryDESCR)
561*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE)
562*c87b03e5Sespie && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */
563*c87b03e5Sespie || (bt != FFEINFO_basictypeCHARACTER)
564*c87b03e5Sespie || (ai->bt == bt)))
565*c87b03e5Sespie {
566*c87b03e5Sespie warn = TRUE;
567*c87b03e5Sespie refwhy = "passed by descriptor";
568*c87b03e5Sespie }
569*c87b03e5Sespie break;
570*c87b03e5Sespie
571*c87b03e5Sespie case FFEGLOBAL_argsummaryPROC:
572*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryPROC)
573*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummarySUBR)
574*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryFUNC)
575*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE))
576*c87b03e5Sespie {
577*c87b03e5Sespie warn = TRUE;
578*c87b03e5Sespie refwhy = "a procedure";
579*c87b03e5Sespie }
580*c87b03e5Sespie break;
581*c87b03e5Sespie
582*c87b03e5Sespie case FFEGLOBAL_argsummarySUBR:
583*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryPROC)
584*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummarySUBR)
585*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE))
586*c87b03e5Sespie {
587*c87b03e5Sespie warn = TRUE;
588*c87b03e5Sespie refwhy = "a subroutine";
589*c87b03e5Sespie }
590*c87b03e5Sespie break;
591*c87b03e5Sespie
592*c87b03e5Sespie case FFEGLOBAL_argsummaryFUNC:
593*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryPROC)
594*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryFUNC)
595*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE))
596*c87b03e5Sespie {
597*c87b03e5Sespie warn = TRUE;
598*c87b03e5Sespie refwhy = "a function";
599*c87b03e5Sespie }
600*c87b03e5Sespie break;
601*c87b03e5Sespie
602*c87b03e5Sespie case FFEGLOBAL_argsummaryALTRTN:
603*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
604*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE))
605*c87b03e5Sespie {
606*c87b03e5Sespie warn = TRUE;
607*c87b03e5Sespie refwhy = "an alternate-return label";
608*c87b03e5Sespie }
609*c87b03e5Sespie break;
610*c87b03e5Sespie
611*c87b03e5Sespie default:
612*c87b03e5Sespie break;
613*c87b03e5Sespie }
614*c87b03e5Sespie
615*c87b03e5Sespie if ((refwhy != NULL) && (defwhy == NULL))
616*c87b03e5Sespie {
617*c87b03e5Sespie /* Fill in the def info. */
618*c87b03e5Sespie
619*c87b03e5Sespie switch (ai->as)
620*c87b03e5Sespie {
621*c87b03e5Sespie case FFEGLOBAL_argsummaryNONE:
622*c87b03e5Sespie defwhy = "omitted";
623*c87b03e5Sespie break;
624*c87b03e5Sespie
625*c87b03e5Sespie case FFEGLOBAL_argsummaryVAL:
626*c87b03e5Sespie defwhy = "passed by value";
627*c87b03e5Sespie break;
628*c87b03e5Sespie
629*c87b03e5Sespie case FFEGLOBAL_argsummaryREF:
630*c87b03e5Sespie defwhy = "passed by reference";
631*c87b03e5Sespie break;
632*c87b03e5Sespie
633*c87b03e5Sespie case FFEGLOBAL_argsummaryDESCR:
634*c87b03e5Sespie defwhy = "passed by descriptor";
635*c87b03e5Sespie break;
636*c87b03e5Sespie
637*c87b03e5Sespie case FFEGLOBAL_argsummaryPROC:
638*c87b03e5Sespie defwhy = "a procedure";
639*c87b03e5Sespie break;
640*c87b03e5Sespie
641*c87b03e5Sespie case FFEGLOBAL_argsummarySUBR:
642*c87b03e5Sespie defwhy = "a subroutine";
643*c87b03e5Sespie break;
644*c87b03e5Sespie
645*c87b03e5Sespie case FFEGLOBAL_argsummaryFUNC:
646*c87b03e5Sespie defwhy = "a function";
647*c87b03e5Sespie break;
648*c87b03e5Sespie
649*c87b03e5Sespie case FFEGLOBAL_argsummaryALTRTN:
650*c87b03e5Sespie defwhy = "an alternate-return label";
651*c87b03e5Sespie break;
652*c87b03e5Sespie
653*c87b03e5Sespie #if 0
654*c87b03e5Sespie case FFEGLOBAL_argsummaryPTR:
655*c87b03e5Sespie defwhy = "a pointer";
656*c87b03e5Sespie break;
657*c87b03e5Sespie #endif
658*c87b03e5Sespie
659*c87b03e5Sespie default:
660*c87b03e5Sespie defwhy = "???";
661*c87b03e5Sespie break;
662*c87b03e5Sespie }
663*c87b03e5Sespie }
664*c87b03e5Sespie
665*c87b03e5Sespie if (!warn
666*c87b03e5Sespie && (bt != FFEINFO_basictypeHOLLERITH)
667*c87b03e5Sespie && (bt != FFEINFO_basictypeTYPELESS)
668*c87b03e5Sespie && (bt != FFEINFO_basictypeNONE)
669*c87b03e5Sespie && (ai->bt != FFEINFO_basictypeHOLLERITH)
670*c87b03e5Sespie && (ai->bt != FFEINFO_basictypeTYPELESS)
671*c87b03e5Sespie && (ai->bt != FFEINFO_basictypeNONE))
672*c87b03e5Sespie {
673*c87b03e5Sespie /* Check types. */
674*c87b03e5Sespie
675*c87b03e5Sespie if ((bt != ai->bt)
676*c87b03e5Sespie && ((bt != FFEINFO_basictypeREAL)
677*c87b03e5Sespie || (ai->bt != FFEINFO_basictypeCOMPLEX))
678*c87b03e5Sespie && ((bt != FFEINFO_basictypeCOMPLEX)
679*c87b03e5Sespie || (ai->bt != FFEINFO_basictypeREAL)))
680*c87b03e5Sespie {
681*c87b03e5Sespie warn = TRUE; /* We can cope with these differences. */
682*c87b03e5Sespie refwhy = "one type";
683*c87b03e5Sespie defwhy = "some other type";
684*c87b03e5Sespie }
685*c87b03e5Sespie
686*c87b03e5Sespie if (!warn && (kt != ai->kt))
687*c87b03e5Sespie {
688*c87b03e5Sespie warn = TRUE;
689*c87b03e5Sespie refwhy = "one precision";
690*c87b03e5Sespie defwhy = "some other precision";
691*c87b03e5Sespie }
692*c87b03e5Sespie }
693*c87b03e5Sespie
694*c87b03e5Sespie if (warn)
695*c87b03e5Sespie {
696*c87b03e5Sespie char num[60];
697*c87b03e5Sespie
698*c87b03e5Sespie if (name == NULL)
699*c87b03e5Sespie sprintf (&num[0], "%d", argno + 1);
700*c87b03e5Sespie else
701*c87b03e5Sespie {
702*c87b03e5Sespie if (strlen (name) < 30)
703*c87b03e5Sespie sprintf (&num[0], "%d (named `%s')", argno + 1, name);
704*c87b03e5Sespie else
705*c87b03e5Sespie sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, name);
706*c87b03e5Sespie }
707*c87b03e5Sespie ffebad_start (FFEBAD_FILEWIDE_ARG_W);
708*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
709*c87b03e5Sespie ffebad_string (num);
710*c87b03e5Sespie ffebad_string (refwhy);
711*c87b03e5Sespie ffebad_string (defwhy);
712*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t));
713*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
714*c87b03e5Sespie ffebad_finish ();
715*c87b03e5Sespie }
716*c87b03e5Sespie }
717*c87b03e5Sespie
718*c87b03e5Sespie /* Define this argument. */
719*c87b03e5Sespie
720*c87b03e5Sespie if (ai->t != NULL)
721*c87b03e5Sespie ffelex_token_kill (ai->t);
722*c87b03e5Sespie if ((as != FFEGLOBAL_argsummaryPROC)
723*c87b03e5Sespie || (ai->t == NULL))
724*c87b03e5Sespie ai->as = as; /* Otherwise leave SUBR/FUNC info intact. */
725*c87b03e5Sespie ai->t = ffelex_token_use (g->t);
726*c87b03e5Sespie if (name == NULL)
727*c87b03e5Sespie ai->name = NULL;
728*c87b03e5Sespie else
729*c87b03e5Sespie {
730*c87b03e5Sespie ai->name = malloc_new_ks (malloc_pool_image (),
731*c87b03e5Sespie "ffeglobalArgInfo_ name",
732*c87b03e5Sespie strlen (name) + 1);
733*c87b03e5Sespie strcpy (ai->name, name);
734*c87b03e5Sespie }
735*c87b03e5Sespie ai->bt = bt;
736*c87b03e5Sespie ai->kt = kt;
737*c87b03e5Sespie ai->array = array;
738*c87b03e5Sespie }
739*c87b03e5Sespie
740*c87b03e5Sespie /* Collect info on #args a global accepts. */
741*c87b03e5Sespie
742*c87b03e5Sespie void
ffeglobal_proc_def_nargs(ffesymbol s,int n_args)743*c87b03e5Sespie ffeglobal_proc_def_nargs (ffesymbol s, int n_args)
744*c87b03e5Sespie {
745*c87b03e5Sespie ffeglobal g = ffesymbol_global (s);
746*c87b03e5Sespie
747*c87b03e5Sespie assert (g != NULL);
748*c87b03e5Sespie
749*c87b03e5Sespie if (g->type == FFEGLOBAL_typeANY)
750*c87b03e5Sespie return;
751*c87b03e5Sespie
752*c87b03e5Sespie if (g->u.proc.n_args >= 0)
753*c87b03e5Sespie {
754*c87b03e5Sespie if (g->u.proc.n_args == n_args)
755*c87b03e5Sespie return;
756*c87b03e5Sespie
757*c87b03e5Sespie if (ffe_is_warn_globals ())
758*c87b03e5Sespie {
759*c87b03e5Sespie ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
760*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
761*c87b03e5Sespie if (g->u.proc.n_args > n_args)
762*c87b03e5Sespie ffebad_string ("few");
763*c87b03e5Sespie else
764*c87b03e5Sespie ffebad_string ("many");
765*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (g->u.proc.other_t),
766*c87b03e5Sespie ffelex_token_where_column (g->u.proc.other_t));
767*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
768*c87b03e5Sespie ffelex_token_where_column (g->t));
769*c87b03e5Sespie ffebad_finish ();
770*c87b03e5Sespie }
771*c87b03e5Sespie }
772*c87b03e5Sespie
773*c87b03e5Sespie /* This is new info we can use in cross-checking future references
774*c87b03e5Sespie and a possible future definition. */
775*c87b03e5Sespie
776*c87b03e5Sespie g->u.proc.n_args = n_args;
777*c87b03e5Sespie g->u.proc.other_t = NULL; /* No other reference yet. */
778*c87b03e5Sespie
779*c87b03e5Sespie if (n_args == 0)
780*c87b03e5Sespie {
781*c87b03e5Sespie g->u.proc.arg_info = NULL;
782*c87b03e5Sespie return;
783*c87b03e5Sespie }
784*c87b03e5Sespie
785*c87b03e5Sespie g->u.proc.arg_info
786*c87b03e5Sespie = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (),
787*c87b03e5Sespie "ffeglobalArgInfo_",
788*c87b03e5Sespie n_args * sizeof (g->u.proc.arg_info[0]));
789*c87b03e5Sespie while (n_args-- > 0)
790*c87b03e5Sespie g->u.proc.arg_info[n_args].t = NULL;
791*c87b03e5Sespie }
792*c87b03e5Sespie
793*c87b03e5Sespie /* Verify that the info for a global's argument is valid. */
794*c87b03e5Sespie
795*c87b03e5Sespie bool
ffeglobal_proc_ref_arg(ffesymbol s,int argno,ffeglobalArgSummary as,ffeinfoBasictype bt,ffeinfoKindtype kt,bool array,ffelexToken t)796*c87b03e5Sespie ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as,
797*c87b03e5Sespie ffeinfoBasictype bt, ffeinfoKindtype kt,
798*c87b03e5Sespie bool array, ffelexToken t)
799*c87b03e5Sespie {
800*c87b03e5Sespie ffeglobal g = ffesymbol_global (s);
801*c87b03e5Sespie ffeglobalArgInfo_ ai;
802*c87b03e5Sespie
803*c87b03e5Sespie assert (g != NULL);
804*c87b03e5Sespie
805*c87b03e5Sespie if (g->type == FFEGLOBAL_typeANY)
806*c87b03e5Sespie return FALSE;
807*c87b03e5Sespie
808*c87b03e5Sespie assert (g->u.proc.n_args >= 0);
809*c87b03e5Sespie
810*c87b03e5Sespie if (argno >= g->u.proc.n_args)
811*c87b03e5Sespie return TRUE; /* Already complained about this discrepancy. */
812*c87b03e5Sespie
813*c87b03e5Sespie ai = &g->u.proc.arg_info[argno];
814*c87b03e5Sespie
815*c87b03e5Sespie /* Warn about previous references. */
816*c87b03e5Sespie
817*c87b03e5Sespie if (ai->t != NULL)
818*c87b03e5Sespie {
819*c87b03e5Sespie const char *refwhy = NULL;
820*c87b03e5Sespie const char *defwhy = NULL;
821*c87b03e5Sespie bool fail = FALSE;
822*c87b03e5Sespie bool warn = FALSE;
823*c87b03e5Sespie
824*c87b03e5Sespie switch (as)
825*c87b03e5Sespie {
826*c87b03e5Sespie case FFEGLOBAL_argsummaryNONE:
827*c87b03e5Sespie if (g->u.proc.defined)
828*c87b03e5Sespie {
829*c87b03e5Sespie fail = TRUE;
830*c87b03e5Sespie refwhy = "omitted";
831*c87b03e5Sespie defwhy = "not optional";
832*c87b03e5Sespie }
833*c87b03e5Sespie break;
834*c87b03e5Sespie
835*c87b03e5Sespie case FFEGLOBAL_argsummaryVAL:
836*c87b03e5Sespie if (ai->as != FFEGLOBAL_argsummaryVAL)
837*c87b03e5Sespie {
838*c87b03e5Sespie fail = TRUE;
839*c87b03e5Sespie refwhy = "passed by value";
840*c87b03e5Sespie }
841*c87b03e5Sespie break;
842*c87b03e5Sespie
843*c87b03e5Sespie case FFEGLOBAL_argsummaryREF:
844*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryREF)
845*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE)
846*c87b03e5Sespie && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */
847*c87b03e5Sespie || (ai->bt != FFEINFO_basictypeCHARACTER)
848*c87b03e5Sespie || (ai->bt == bt)))
849*c87b03e5Sespie {
850*c87b03e5Sespie fail = TRUE;
851*c87b03e5Sespie refwhy = "passed by reference";
852*c87b03e5Sespie }
853*c87b03e5Sespie break;
854*c87b03e5Sespie
855*c87b03e5Sespie case FFEGLOBAL_argsummaryDESCR:
856*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryDESCR)
857*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE)
858*c87b03e5Sespie && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */
859*c87b03e5Sespie || (bt != FFEINFO_basictypeCHARACTER)
860*c87b03e5Sespie || (ai->bt == bt)))
861*c87b03e5Sespie {
862*c87b03e5Sespie fail = TRUE;
863*c87b03e5Sespie refwhy = "passed by descriptor";
864*c87b03e5Sespie }
865*c87b03e5Sespie break;
866*c87b03e5Sespie
867*c87b03e5Sespie case FFEGLOBAL_argsummaryPROC:
868*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryPROC)
869*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummarySUBR)
870*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryFUNC)
871*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE))
872*c87b03e5Sespie {
873*c87b03e5Sespie fail = TRUE;
874*c87b03e5Sespie refwhy = "a procedure";
875*c87b03e5Sespie }
876*c87b03e5Sespie break;
877*c87b03e5Sespie
878*c87b03e5Sespie case FFEGLOBAL_argsummarySUBR:
879*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryPROC)
880*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummarySUBR)
881*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE))
882*c87b03e5Sespie {
883*c87b03e5Sespie fail = TRUE;
884*c87b03e5Sespie refwhy = "a subroutine";
885*c87b03e5Sespie }
886*c87b03e5Sespie break;
887*c87b03e5Sespie
888*c87b03e5Sespie case FFEGLOBAL_argsummaryFUNC:
889*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryPROC)
890*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryFUNC)
891*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE))
892*c87b03e5Sespie {
893*c87b03e5Sespie fail = TRUE;
894*c87b03e5Sespie refwhy = "a function";
895*c87b03e5Sespie }
896*c87b03e5Sespie break;
897*c87b03e5Sespie
898*c87b03e5Sespie case FFEGLOBAL_argsummaryALTRTN:
899*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
900*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE))
901*c87b03e5Sespie {
902*c87b03e5Sespie fail = TRUE;
903*c87b03e5Sespie refwhy = "an alternate-return label";
904*c87b03e5Sespie }
905*c87b03e5Sespie break;
906*c87b03e5Sespie
907*c87b03e5Sespie #if 0
908*c87b03e5Sespie case FFEGLOBAL_argsummaryPTR:
909*c87b03e5Sespie if ((ai->as != FFEGLOBAL_argsummaryPTR)
910*c87b03e5Sespie && (ai->as != FFEGLOBAL_argsummaryNONE))
911*c87b03e5Sespie {
912*c87b03e5Sespie fail = TRUE;
913*c87b03e5Sespie refwhy = "a pointer";
914*c87b03e5Sespie }
915*c87b03e5Sespie break;
916*c87b03e5Sespie #endif
917*c87b03e5Sespie
918*c87b03e5Sespie default:
919*c87b03e5Sespie break;
920*c87b03e5Sespie }
921*c87b03e5Sespie
922*c87b03e5Sespie if ((refwhy != NULL) && (defwhy == NULL))
923*c87b03e5Sespie {
924*c87b03e5Sespie /* Fill in the def info. */
925*c87b03e5Sespie
926*c87b03e5Sespie switch (ai->as)
927*c87b03e5Sespie {
928*c87b03e5Sespie case FFEGLOBAL_argsummaryNONE:
929*c87b03e5Sespie defwhy = "omitted";
930*c87b03e5Sespie break;
931*c87b03e5Sespie
932*c87b03e5Sespie case FFEGLOBAL_argsummaryVAL:
933*c87b03e5Sespie defwhy = "passed by value";
934*c87b03e5Sespie break;
935*c87b03e5Sespie
936*c87b03e5Sespie case FFEGLOBAL_argsummaryREF:
937*c87b03e5Sespie defwhy = "passed by reference";
938*c87b03e5Sespie break;
939*c87b03e5Sespie
940*c87b03e5Sespie case FFEGLOBAL_argsummaryDESCR:
941*c87b03e5Sespie defwhy = "passed by descriptor";
942*c87b03e5Sespie break;
943*c87b03e5Sespie
944*c87b03e5Sespie case FFEGLOBAL_argsummaryPROC:
945*c87b03e5Sespie defwhy = "a procedure";
946*c87b03e5Sespie break;
947*c87b03e5Sespie
948*c87b03e5Sespie case FFEGLOBAL_argsummarySUBR:
949*c87b03e5Sespie defwhy = "a subroutine";
950*c87b03e5Sespie break;
951*c87b03e5Sespie
952*c87b03e5Sespie case FFEGLOBAL_argsummaryFUNC:
953*c87b03e5Sespie defwhy = "a function";
954*c87b03e5Sespie break;
955*c87b03e5Sespie
956*c87b03e5Sespie case FFEGLOBAL_argsummaryALTRTN:
957*c87b03e5Sespie defwhy = "an alternate-return label";
958*c87b03e5Sespie break;
959*c87b03e5Sespie
960*c87b03e5Sespie #if 0
961*c87b03e5Sespie case FFEGLOBAL_argsummaryPTR:
962*c87b03e5Sespie defwhy = "a pointer";
963*c87b03e5Sespie break;
964*c87b03e5Sespie #endif
965*c87b03e5Sespie
966*c87b03e5Sespie default:
967*c87b03e5Sespie defwhy = "???";
968*c87b03e5Sespie break;
969*c87b03e5Sespie }
970*c87b03e5Sespie }
971*c87b03e5Sespie
972*c87b03e5Sespie if (!fail && !warn
973*c87b03e5Sespie && (bt != FFEINFO_basictypeHOLLERITH)
974*c87b03e5Sespie && (bt != FFEINFO_basictypeTYPELESS)
975*c87b03e5Sespie && (bt != FFEINFO_basictypeNONE)
976*c87b03e5Sespie && (ai->bt != FFEINFO_basictypeHOLLERITH)
977*c87b03e5Sespie && (ai->bt != FFEINFO_basictypeNONE)
978*c87b03e5Sespie && (ai->bt != FFEINFO_basictypeTYPELESS))
979*c87b03e5Sespie {
980*c87b03e5Sespie /* Check types. */
981*c87b03e5Sespie
982*c87b03e5Sespie if ((bt != ai->bt)
983*c87b03e5Sespie && ((bt != FFEINFO_basictypeREAL)
984*c87b03e5Sespie || (ai->bt != FFEINFO_basictypeCOMPLEX))
985*c87b03e5Sespie && ((bt != FFEINFO_basictypeCOMPLEX)
986*c87b03e5Sespie || (ai->bt != FFEINFO_basictypeREAL)))
987*c87b03e5Sespie {
988*c87b03e5Sespie if (((bt == FFEINFO_basictypeINTEGER)
989*c87b03e5Sespie && (ai->bt == FFEINFO_basictypeLOGICAL))
990*c87b03e5Sespie || ((bt == FFEINFO_basictypeLOGICAL)
991*c87b03e5Sespie && (ai->bt == FFEINFO_basictypeINTEGER)))
992*c87b03e5Sespie warn = TRUE; /* We can cope with these differences. */
993*c87b03e5Sespie else
994*c87b03e5Sespie fail = TRUE;
995*c87b03e5Sespie refwhy = "one type";
996*c87b03e5Sespie defwhy = "some other type";
997*c87b03e5Sespie }
998*c87b03e5Sespie
999*c87b03e5Sespie if (!fail && !warn && (kt != ai->kt))
1000*c87b03e5Sespie {
1001*c87b03e5Sespie fail = TRUE;
1002*c87b03e5Sespie refwhy = "one precision";
1003*c87b03e5Sespie defwhy = "some other precision";
1004*c87b03e5Sespie }
1005*c87b03e5Sespie }
1006*c87b03e5Sespie
1007*c87b03e5Sespie if (fail && ! g->u.proc.defined)
1008*c87b03e5Sespie {
1009*c87b03e5Sespie /* No point failing if we're worried only about invocations. */
1010*c87b03e5Sespie fail = FALSE;
1011*c87b03e5Sespie warn = TRUE;
1012*c87b03e5Sespie }
1013*c87b03e5Sespie
1014*c87b03e5Sespie if (fail && ! ffe_is_globals ())
1015*c87b03e5Sespie {
1016*c87b03e5Sespie warn = TRUE;
1017*c87b03e5Sespie fail = FALSE;
1018*c87b03e5Sespie }
1019*c87b03e5Sespie
1020*c87b03e5Sespie if (fail || (warn && ffe_is_warn_globals ()))
1021*c87b03e5Sespie {
1022*c87b03e5Sespie char num[60];
1023*c87b03e5Sespie
1024*c87b03e5Sespie if (ai->name == NULL)
1025*c87b03e5Sespie sprintf (&num[0], "%d", argno + 1);
1026*c87b03e5Sespie else
1027*c87b03e5Sespie {
1028*c87b03e5Sespie if (strlen (ai->name) < 30)
1029*c87b03e5Sespie sprintf (&num[0], "%d (named `%s')", argno + 1, ai->name);
1030*c87b03e5Sespie else
1031*c87b03e5Sespie sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, ai->name);
1032*c87b03e5Sespie }
1033*c87b03e5Sespie ffebad_start (fail ? FFEBAD_FILEWIDE_ARG : FFEBAD_FILEWIDE_ARG_W);
1034*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
1035*c87b03e5Sespie ffebad_string (num);
1036*c87b03e5Sespie ffebad_string (refwhy);
1037*c87b03e5Sespie ffebad_string (defwhy);
1038*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1039*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
1040*c87b03e5Sespie ffebad_finish ();
1041*c87b03e5Sespie return (fail ? FALSE : TRUE);
1042*c87b03e5Sespie }
1043*c87b03e5Sespie
1044*c87b03e5Sespie if (warn)
1045*c87b03e5Sespie return TRUE;
1046*c87b03e5Sespie }
1047*c87b03e5Sespie
1048*c87b03e5Sespie /* Define this argument. */
1049*c87b03e5Sespie
1050*c87b03e5Sespie if (ai->t != NULL)
1051*c87b03e5Sespie ffelex_token_kill (ai->t);
1052*c87b03e5Sespie if ((as != FFEGLOBAL_argsummaryPROC)
1053*c87b03e5Sespie || (ai->t == NULL))
1054*c87b03e5Sespie ai->as = as;
1055*c87b03e5Sespie ai->t = ffelex_token_use (g->t);
1056*c87b03e5Sespie ai->name = NULL;
1057*c87b03e5Sespie ai->bt = bt;
1058*c87b03e5Sespie ai->kt = kt;
1059*c87b03e5Sespie ai->array = array;
1060*c87b03e5Sespie return TRUE;
1061*c87b03e5Sespie }
1062*c87b03e5Sespie
1063*c87b03e5Sespie bool
ffeglobal_proc_ref_nargs(ffesymbol s,int n_args,ffelexToken t)1064*c87b03e5Sespie ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t)
1065*c87b03e5Sespie {
1066*c87b03e5Sespie ffeglobal g = ffesymbol_global (s);
1067*c87b03e5Sespie
1068*c87b03e5Sespie assert (g != NULL);
1069*c87b03e5Sespie
1070*c87b03e5Sespie if (g->type == FFEGLOBAL_typeANY)
1071*c87b03e5Sespie return FALSE;
1072*c87b03e5Sespie
1073*c87b03e5Sespie if (g->u.proc.n_args >= 0)
1074*c87b03e5Sespie {
1075*c87b03e5Sespie if (g->u.proc.n_args == n_args)
1076*c87b03e5Sespie return TRUE;
1077*c87b03e5Sespie
1078*c87b03e5Sespie if (g->u.proc.defined && ffe_is_globals ())
1079*c87b03e5Sespie {
1080*c87b03e5Sespie ffebad_start (FFEBAD_FILEWIDE_NARGS);
1081*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
1082*c87b03e5Sespie if (g->u.proc.n_args > n_args)
1083*c87b03e5Sespie ffebad_string ("few");
1084*c87b03e5Sespie else
1085*c87b03e5Sespie ffebad_string ("many");
1086*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1087*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
1088*c87b03e5Sespie ffelex_token_where_column (g->t));
1089*c87b03e5Sespie ffebad_finish ();
1090*c87b03e5Sespie return FALSE;
1091*c87b03e5Sespie }
1092*c87b03e5Sespie
1093*c87b03e5Sespie if (ffe_is_warn_globals ())
1094*c87b03e5Sespie {
1095*c87b03e5Sespie ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
1096*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
1097*c87b03e5Sespie if (g->u.proc.n_args > n_args)
1098*c87b03e5Sespie ffebad_string ("few");
1099*c87b03e5Sespie else
1100*c87b03e5Sespie ffebad_string ("many");
1101*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1102*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
1103*c87b03e5Sespie ffelex_token_where_column (g->t));
1104*c87b03e5Sespie ffebad_finish ();
1105*c87b03e5Sespie }
1106*c87b03e5Sespie
1107*c87b03e5Sespie return TRUE; /* Don't replace the info we already have. */
1108*c87b03e5Sespie }
1109*c87b03e5Sespie
1110*c87b03e5Sespie /* This is new info we can use in cross-checking future references
1111*c87b03e5Sespie and a possible future definition. */
1112*c87b03e5Sespie
1113*c87b03e5Sespie g->u.proc.n_args = n_args;
1114*c87b03e5Sespie g->u.proc.other_t = ffelex_token_use (t);
1115*c87b03e5Sespie
1116*c87b03e5Sespie /* Make this "the" place we found the global, since it has the most info. */
1117*c87b03e5Sespie
1118*c87b03e5Sespie if (g->t != NULL)
1119*c87b03e5Sespie ffelex_token_kill (g->t);
1120*c87b03e5Sespie g->t = ffelex_token_use (t);
1121*c87b03e5Sespie
1122*c87b03e5Sespie if (n_args == 0)
1123*c87b03e5Sespie {
1124*c87b03e5Sespie g->u.proc.arg_info = NULL;
1125*c87b03e5Sespie return TRUE;
1126*c87b03e5Sespie }
1127*c87b03e5Sespie
1128*c87b03e5Sespie g->u.proc.arg_info
1129*c87b03e5Sespie = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (),
1130*c87b03e5Sespie "ffeglobalArgInfo_",
1131*c87b03e5Sespie n_args * sizeof (g->u.proc.arg_info[0]));
1132*c87b03e5Sespie while (n_args-- > 0)
1133*c87b03e5Sespie g->u.proc.arg_info[n_args].t = NULL;
1134*c87b03e5Sespie
1135*c87b03e5Sespie return TRUE;
1136*c87b03e5Sespie }
1137*c87b03e5Sespie
1138*c87b03e5Sespie /* Return a global for a promoted symbol (one that has heretofore
1139*c87b03e5Sespie been assumed to be local, but since discovered to be global). */
1140*c87b03e5Sespie
1141*c87b03e5Sespie ffeglobal
ffeglobal_promoted(ffesymbol s)1142*c87b03e5Sespie ffeglobal_promoted (ffesymbol s)
1143*c87b03e5Sespie {
1144*c87b03e5Sespie #if FFEGLOBAL_ENABLED
1145*c87b03e5Sespie ffename n;
1146*c87b03e5Sespie ffeglobal g;
1147*c87b03e5Sespie
1148*c87b03e5Sespie assert (ffesymbol_global (s) == NULL);
1149*c87b03e5Sespie
1150*c87b03e5Sespie n = ffename_find (ffeglobal_filewide_, ffename_token (ffesymbol_name (s)));
1151*c87b03e5Sespie g = ffename_global (n);
1152*c87b03e5Sespie
1153*c87b03e5Sespie return g;
1154*c87b03e5Sespie #else
1155*c87b03e5Sespie return NULL;
1156*c87b03e5Sespie #endif
1157*c87b03e5Sespie }
1158*c87b03e5Sespie
1159*c87b03e5Sespie /* Register a reference to an intrinsic. Such a reference is always
1160*c87b03e5Sespie valid, though a warning might be in order if the same name has
1161*c87b03e5Sespie already been used for a global. */
1162*c87b03e5Sespie
1163*c87b03e5Sespie void
ffeglobal_ref_intrinsic(ffesymbol s,ffelexToken t,bool explicit)1164*c87b03e5Sespie ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit)
1165*c87b03e5Sespie {
1166*c87b03e5Sespie #if FFEGLOBAL_ENABLED
1167*c87b03e5Sespie ffename n;
1168*c87b03e5Sespie ffeglobal g;
1169*c87b03e5Sespie
1170*c87b03e5Sespie if (ffesymbol_global (s) == NULL)
1171*c87b03e5Sespie {
1172*c87b03e5Sespie n = ffename_find (ffeglobal_filewide_, t);
1173*c87b03e5Sespie g = ffename_global (n);
1174*c87b03e5Sespie }
1175*c87b03e5Sespie else
1176*c87b03e5Sespie {
1177*c87b03e5Sespie g = ffesymbol_global (s);
1178*c87b03e5Sespie n = NULL;
1179*c87b03e5Sespie }
1180*c87b03e5Sespie
1181*c87b03e5Sespie if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
1182*c87b03e5Sespie return;
1183*c87b03e5Sespie
1184*c87b03e5Sespie if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
1185*c87b03e5Sespie {
1186*c87b03e5Sespie if (! explicit
1187*c87b03e5Sespie && ! g->intrinsic
1188*c87b03e5Sespie && ffe_is_warn_globals ())
1189*c87b03e5Sespie {
1190*c87b03e5Sespie /* This name, previously used as a global, now is used
1191*c87b03e5Sespie for an intrinsic. Warn, since this new use as an
1192*c87b03e5Sespie intrinsic might have been intended to refer to
1193*c87b03e5Sespie the global procedure. */
1194*c87b03e5Sespie ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
1195*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
1196*c87b03e5Sespie ffebad_string ("intrinsic");
1197*c87b03e5Sespie ffebad_string ("global");
1198*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1199*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
1200*c87b03e5Sespie ffelex_token_where_column (g->t));
1201*c87b03e5Sespie ffebad_finish ();
1202*c87b03e5Sespie }
1203*c87b03e5Sespie }
1204*c87b03e5Sespie else
1205*c87b03e5Sespie {
1206*c87b03e5Sespie if (g == NULL)
1207*c87b03e5Sespie {
1208*c87b03e5Sespie g = ffeglobal_new_ (n);
1209*c87b03e5Sespie g->tick = ffe_count_2;
1210*c87b03e5Sespie g->type = FFEGLOBAL_typeNONE;
1211*c87b03e5Sespie g->intrinsic = TRUE;
1212*c87b03e5Sespie g->explicit_intrinsic = explicit;
1213*c87b03e5Sespie g->t = ffelex_token_use (t);
1214*c87b03e5Sespie }
1215*c87b03e5Sespie else if (g->intrinsic
1216*c87b03e5Sespie && (explicit != g->explicit_intrinsic)
1217*c87b03e5Sespie && (g->tick != ffe_count_2)
1218*c87b03e5Sespie && ffe_is_warn_globals ())
1219*c87b03e5Sespie {
1220*c87b03e5Sespie /* An earlier reference to this intrinsic disagrees with
1221*c87b03e5Sespie this reference vis-a-vis explicit `intrinsic foo',
1222*c87b03e5Sespie which suggests that the one relying on implicit
1223*c87b03e5Sespie intrinsicacity might have actually intended to refer
1224*c87b03e5Sespie to a global of the same name. */
1225*c87b03e5Sespie ffebad_start (FFEBAD_INTRINSIC_EXPIMP);
1226*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
1227*c87b03e5Sespie ffebad_string (explicit ? "explicit" : "implicit");
1228*c87b03e5Sespie ffebad_string (explicit ? "implicit" : "explicit");
1229*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1230*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
1231*c87b03e5Sespie ffelex_token_where_column (g->t));
1232*c87b03e5Sespie ffebad_finish ();
1233*c87b03e5Sespie }
1234*c87b03e5Sespie }
1235*c87b03e5Sespie
1236*c87b03e5Sespie g->intrinsic = TRUE;
1237*c87b03e5Sespie if (explicit)
1238*c87b03e5Sespie g->explicit_intrinsic = TRUE;
1239*c87b03e5Sespie
1240*c87b03e5Sespie ffesymbol_set_global (s, g);
1241*c87b03e5Sespie #endif
1242*c87b03e5Sespie }
1243*c87b03e5Sespie
1244*c87b03e5Sespie /* Register a reference to a global. Returns TRUE if the reference
1245*c87b03e5Sespie is valid. */
1246*c87b03e5Sespie
1247*c87b03e5Sespie bool
ffeglobal_ref_progunit_(ffesymbol s,ffelexToken t,ffeglobalType type)1248*c87b03e5Sespie ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
1249*c87b03e5Sespie {
1250*c87b03e5Sespie #if FFEGLOBAL_ENABLED
1251*c87b03e5Sespie ffename n = NULL;
1252*c87b03e5Sespie ffeglobal g;
1253*c87b03e5Sespie
1254*c87b03e5Sespie /* It is never really _known_ that an EXTERNAL statement
1255*c87b03e5Sespie names a BLOCK DATA by just looking at the program unit,
1256*c87b03e5Sespie so override a different notion here. */
1257*c87b03e5Sespie if (type == FFEGLOBAL_typeBDATA)
1258*c87b03e5Sespie type = FFEGLOBAL_typeEXT;
1259*c87b03e5Sespie
1260*c87b03e5Sespie g = ffesymbol_global (s);
1261*c87b03e5Sespie if (g == NULL)
1262*c87b03e5Sespie {
1263*c87b03e5Sespie n = ffename_find (ffeglobal_filewide_, t);
1264*c87b03e5Sespie g = ffename_global (n);
1265*c87b03e5Sespie if (g != NULL)
1266*c87b03e5Sespie ffesymbol_set_global (s, g);
1267*c87b03e5Sespie }
1268*c87b03e5Sespie
1269*c87b03e5Sespie if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
1270*c87b03e5Sespie return TRUE;
1271*c87b03e5Sespie
1272*c87b03e5Sespie if ((g != NULL)
1273*c87b03e5Sespie && (g->type != FFEGLOBAL_typeNONE)
1274*c87b03e5Sespie && (g->type != FFEGLOBAL_typeEXT)
1275*c87b03e5Sespie && (g->type != type)
1276*c87b03e5Sespie && (type != FFEGLOBAL_typeEXT))
1277*c87b03e5Sespie {
1278*c87b03e5Sespie /* Disagreement about (fully refined) class of program unit
1279*c87b03e5Sespie (main, subroutine, function, block data). Treat EXTERNAL/
1280*c87b03e5Sespie COMMON disagreements distinctly. */
1281*c87b03e5Sespie if ((((type == FFEGLOBAL_typeBDATA)
1282*c87b03e5Sespie && (g->type != FFEGLOBAL_typeCOMMON))
1283*c87b03e5Sespie || ((g->type == FFEGLOBAL_typeBDATA)
1284*c87b03e5Sespie && (type != FFEGLOBAL_typeCOMMON)
1285*c87b03e5Sespie && ! g->u.proc.defined)))
1286*c87b03e5Sespie {
1287*c87b03e5Sespie #if 0 /* This is likely to just annoy people. */
1288*c87b03e5Sespie if (ffe_is_warn_globals ())
1289*c87b03e5Sespie {
1290*c87b03e5Sespie /* Warn about EXTERNAL of a COMMON name, though it works. */
1291*c87b03e5Sespie ffebad_start (FFEBAD_FILEWIDE_TIFF);
1292*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
1293*c87b03e5Sespie ffebad_string (ffeglobal_type_string_[type]);
1294*c87b03e5Sespie ffebad_string (ffeglobal_type_string_[g->type]);
1295*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t),
1296*c87b03e5Sespie ffelex_token_where_column (t));
1297*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
1298*c87b03e5Sespie ffelex_token_where_column (g->t));
1299*c87b03e5Sespie ffebad_finish ();
1300*c87b03e5Sespie }
1301*c87b03e5Sespie #endif
1302*c87b03e5Sespie }
1303*c87b03e5Sespie else if (ffe_is_globals () || ffe_is_warn_globals ())
1304*c87b03e5Sespie {
1305*c87b03e5Sespie ffebad_start (ffe_is_globals ()
1306*c87b03e5Sespie ? FFEBAD_FILEWIDE_DISAGREEMENT
1307*c87b03e5Sespie : FFEBAD_FILEWIDE_DISAGREEMENT_W);
1308*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
1309*c87b03e5Sespie ffebad_string (ffeglobal_type_string_[type]);
1310*c87b03e5Sespie ffebad_string (ffeglobal_type_string_[g->type]);
1311*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t),
1312*c87b03e5Sespie ffelex_token_where_column (t));
1313*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
1314*c87b03e5Sespie ffelex_token_where_column (g->t));
1315*c87b03e5Sespie ffebad_finish ();
1316*c87b03e5Sespie g->type = FFEGLOBAL_typeANY;
1317*c87b03e5Sespie return (! ffe_is_globals ());
1318*c87b03e5Sespie }
1319*c87b03e5Sespie }
1320*c87b03e5Sespie
1321*c87b03e5Sespie if ((g != NULL)
1322*c87b03e5Sespie && (type == FFEGLOBAL_typeFUNC))
1323*c87b03e5Sespie {
1324*c87b03e5Sespie /* If just filling in this function's type, do so. */
1325*c87b03e5Sespie if ((g->tick == ffe_count_2)
1326*c87b03e5Sespie && (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
1327*c87b03e5Sespie && (ffesymbol_kindtype (s) != FFEINFO_kindtypeNONE))
1328*c87b03e5Sespie {
1329*c87b03e5Sespie g->u.proc.bt = ffesymbol_basictype (s);
1330*c87b03e5Sespie g->u.proc.kt = ffesymbol_kindtype (s);
1331*c87b03e5Sespie g->u.proc.sz = ffesymbol_size (s);
1332*c87b03e5Sespie }
1333*c87b03e5Sespie /* Make sure there is type agreement. */
1334*c87b03e5Sespie if (g->type == FFEGLOBAL_typeFUNC
1335*c87b03e5Sespie && g->u.proc.bt != FFEINFO_basictypeNONE
1336*c87b03e5Sespie && ffesymbol_basictype (s) != FFEINFO_basictypeNONE
1337*c87b03e5Sespie && (ffesymbol_basictype (s) != g->u.proc.bt
1338*c87b03e5Sespie || ffesymbol_kindtype (s) != g->u.proc.kt
1339*c87b03e5Sespie /* CHARACTER*n disagreements matter only once a
1340*c87b03e5Sespie definition is involved, since the definition might
1341*c87b03e5Sespie be CHARACTER*(*), which accepts all references. */
1342*c87b03e5Sespie || (g->u.proc.defined
1343*c87b03e5Sespie && ffesymbol_size (s) != g->u.proc.sz
1344*c87b03e5Sespie && ffesymbol_size (s) != FFETARGET_charactersizeNONE
1345*c87b03e5Sespie && g->u.proc.sz != FFETARGET_charactersizeNONE)))
1346*c87b03e5Sespie {
1347*c87b03e5Sespie int error;
1348*c87b03e5Sespie
1349*c87b03e5Sespie /* Type mismatch between function reference/definition and
1350*c87b03e5Sespie this subsequent reference (which might just be the filling-in
1351*c87b03e5Sespie of type info for the definition, but we can't reach here
1352*c87b03e5Sespie if that's the case and there was a previous definition).
1353*c87b03e5Sespie
1354*c87b03e5Sespie It's an error given a previous definition, since that
1355*c87b03e5Sespie implies inlining can crash the compiler, unless the user
1356*c87b03e5Sespie asked for no such inlining. */
1357*c87b03e5Sespie error = (g->tick != ffe_count_2
1358*c87b03e5Sespie && g->u.proc.defined
1359*c87b03e5Sespie && ffe_is_globals ());
1360*c87b03e5Sespie if (error || ffe_is_warn_globals ())
1361*c87b03e5Sespie {
1362*c87b03e5Sespie ffebad_start (error
1363*c87b03e5Sespie ? FFEBAD_FILEWIDE_TYPE_MISMATCH
1364*c87b03e5Sespie : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
1365*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
1366*c87b03e5Sespie if (g->tick == ffe_count_2)
1367*c87b03e5Sespie {
1368*c87b03e5Sespie /* Current reference fills in type info for definition.
1369*c87b03e5Sespie The current token doesn't necessarily point to the actual
1370*c87b03e5Sespie definition of the function, so use the definition pointer
1371*c87b03e5Sespie and the pointer to the pre-definition type info. */
1372*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (g->t),
1373*c87b03e5Sespie ffelex_token_where_column (g->t));
1374*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->u.proc.other_t),
1375*c87b03e5Sespie ffelex_token_where_column (g->u.proc.other_t));
1376*c87b03e5Sespie }
1377*c87b03e5Sespie else
1378*c87b03e5Sespie {
1379*c87b03e5Sespie /* Current reference is not a filling-in of a current
1380*c87b03e5Sespie definition. The current token is fine, as is
1381*c87b03e5Sespie the previous-mention token. */
1382*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t),
1383*c87b03e5Sespie ffelex_token_where_column (t));
1384*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
1385*c87b03e5Sespie ffelex_token_where_column (g->t));
1386*c87b03e5Sespie }
1387*c87b03e5Sespie ffebad_finish ();
1388*c87b03e5Sespie if (error)
1389*c87b03e5Sespie g->type = FFEGLOBAL_typeANY;
1390*c87b03e5Sespie return FALSE;
1391*c87b03e5Sespie }
1392*c87b03e5Sespie }
1393*c87b03e5Sespie }
1394*c87b03e5Sespie
1395*c87b03e5Sespie if (g == NULL)
1396*c87b03e5Sespie {
1397*c87b03e5Sespie g = ffeglobal_new_ (n);
1398*c87b03e5Sespie g->t = ffelex_token_use (t);
1399*c87b03e5Sespie g->tick = ffe_count_2;
1400*c87b03e5Sespie g->intrinsic = FALSE;
1401*c87b03e5Sespie g->type = type;
1402*c87b03e5Sespie g->u.proc.defined = FALSE;
1403*c87b03e5Sespie g->u.proc.bt = ffesymbol_basictype (s);
1404*c87b03e5Sespie g->u.proc.kt = ffesymbol_kindtype (s);
1405*c87b03e5Sespie g->u.proc.sz = ffesymbol_size (s);
1406*c87b03e5Sespie g->u.proc.n_args = -1;
1407*c87b03e5Sespie ffesymbol_set_global (s, g);
1408*c87b03e5Sespie }
1409*c87b03e5Sespie else if (g->intrinsic
1410*c87b03e5Sespie && !g->explicit_intrinsic
1411*c87b03e5Sespie && (g->tick != ffe_count_2)
1412*c87b03e5Sespie && ffe_is_warn_globals ())
1413*c87b03e5Sespie {
1414*c87b03e5Sespie /* Now known as a global, this name previously was seen as an
1415*c87b03e5Sespie intrinsic. Warn, in case the previous reference was intended
1416*c87b03e5Sespie for the same global. */
1417*c87b03e5Sespie ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
1418*c87b03e5Sespie ffebad_string (ffelex_token_text (t));
1419*c87b03e5Sespie ffebad_string ("global");
1420*c87b03e5Sespie ffebad_string ("intrinsic");
1421*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1422*c87b03e5Sespie ffebad_here (1, ffelex_token_where_line (g->t),
1423*c87b03e5Sespie ffelex_token_where_column (g->t));
1424*c87b03e5Sespie ffebad_finish ();
1425*c87b03e5Sespie }
1426*c87b03e5Sespie
1427*c87b03e5Sespie if ((g->type != type)
1428*c87b03e5Sespie && (type != FFEGLOBAL_typeEXT))
1429*c87b03e5Sespie {
1430*c87b03e5Sespie /* We've learned more, so point to where we learned it. */
1431*c87b03e5Sespie g->t = ffelex_token_use (t);
1432*c87b03e5Sespie g->type = type;
1433*c87b03e5Sespie #ifdef FFECOM_globalHOOK
1434*c87b03e5Sespie g->hook = FFECOM_globalNULL; /* Discard previous _DECL. */
1435*c87b03e5Sespie #endif
1436*c87b03e5Sespie g->u.proc.n_args = -1;
1437*c87b03e5Sespie }
1438*c87b03e5Sespie
1439*c87b03e5Sespie return TRUE;
1440*c87b03e5Sespie #endif
1441*c87b03e5Sespie }
1442*c87b03e5Sespie
1443*c87b03e5Sespie /* ffeglobal_save_common -- Check SAVE status of common area
1444*c87b03e5Sespie
1445*c87b03e5Sespie ffesymbol s; // the common area
1446*c87b03e5Sespie bool save; // TRUE if SAVEd, FALSE otherwise
1447*c87b03e5Sespie ffeglobal_save_common(s,save,ffesymbol_where_line(s),
1448*c87b03e5Sespie ffesymbol_where_column(s));
1449*c87b03e5Sespie
1450*c87b03e5Sespie In global-enabled mode, make sure the save info agrees with any existing
1451*c87b03e5Sespie info established for the common area, otherwise complain.
1452*c87b03e5Sespie In global-disabled mode, do nothing. */
1453*c87b03e5Sespie
1454*c87b03e5Sespie void
ffeglobal_save_common(ffesymbol s,bool save,ffewhereLine wl,ffewhereColumn wc)1455*c87b03e5Sespie ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl,
1456*c87b03e5Sespie ffewhereColumn wc)
1457*c87b03e5Sespie {
1458*c87b03e5Sespie #if FFEGLOBAL_ENABLED
1459*c87b03e5Sespie ffeglobal g;
1460*c87b03e5Sespie
1461*c87b03e5Sespie g = ffesymbol_global (s);
1462*c87b03e5Sespie if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
1463*c87b03e5Sespie return; /* Let someone else catch this! */
1464*c87b03e5Sespie if (g->type == FFEGLOBAL_typeANY)
1465*c87b03e5Sespie return;
1466*c87b03e5Sespie
1467*c87b03e5Sespie if (!g->u.common.have_save)
1468*c87b03e5Sespie {
1469*c87b03e5Sespie g->u.common.have_save = TRUE;
1470*c87b03e5Sespie g->u.common.save = save;
1471*c87b03e5Sespie g->u.common.save_where_line = ffewhere_line_use (wl);
1472*c87b03e5Sespie g->u.common.save_where_col = ffewhere_column_use (wc);
1473*c87b03e5Sespie }
1474*c87b03e5Sespie else
1475*c87b03e5Sespie {
1476*c87b03e5Sespie if ((g->u.common.save != save) && ffe_is_pedantic ())
1477*c87b03e5Sespie {
1478*c87b03e5Sespie ffebad_start (FFEBAD_COMMON_DIFF_SAVE);
1479*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
1480*c87b03e5Sespie ffebad_here (save ? 0 : 1, wl, wc);
1481*c87b03e5Sespie ffebad_here (save ? 1 : 0, g->u.common.pad_where_line, g->u.common.pad_where_col);
1482*c87b03e5Sespie ffebad_finish ();
1483*c87b03e5Sespie }
1484*c87b03e5Sespie }
1485*c87b03e5Sespie #endif
1486*c87b03e5Sespie }
1487*c87b03e5Sespie
1488*c87b03e5Sespie /* ffeglobal_size_common -- Establish size of COMMON area
1489*c87b03e5Sespie
1490*c87b03e5Sespie ffesymbol s; // the common area
1491*c87b03e5Sespie ffetargetOffset size; // size in units
1492*c87b03e5Sespie if (ffeglobal_size_common(s,size)) // new size is largest seen
1493*c87b03e5Sespie
1494*c87b03e5Sespie In global-enabled mode, set the size if it current size isn't known or is
1495*c87b03e5Sespie smaller than new size, and for non-blank common, complain if old size
1496*c87b03e5Sespie is different from new. Return TRUE if the new size is the largest seen
1497*c87b03e5Sespie for this COMMON area (or if no size was known for it previously).
1498*c87b03e5Sespie In global-disabled mode, do nothing. */
1499*c87b03e5Sespie
1500*c87b03e5Sespie #if FFEGLOBAL_ENABLED
1501*c87b03e5Sespie bool
ffeglobal_size_common(ffesymbol s,ffetargetOffset size)1502*c87b03e5Sespie ffeglobal_size_common (ffesymbol s, ffetargetOffset size)
1503*c87b03e5Sespie {
1504*c87b03e5Sespie ffeglobal g;
1505*c87b03e5Sespie
1506*c87b03e5Sespie g = ffesymbol_global (s);
1507*c87b03e5Sespie if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
1508*c87b03e5Sespie return FALSE;
1509*c87b03e5Sespie if (g->type == FFEGLOBAL_typeANY)
1510*c87b03e5Sespie return FALSE;
1511*c87b03e5Sespie
1512*c87b03e5Sespie if (!g->u.common.have_size)
1513*c87b03e5Sespie {
1514*c87b03e5Sespie g->u.common.have_size = TRUE;
1515*c87b03e5Sespie g->u.common.size = size;
1516*c87b03e5Sespie return TRUE;
1517*c87b03e5Sespie }
1518*c87b03e5Sespie
1519*c87b03e5Sespie if ((g->tick > 0) && (g->tick < ffe_count_2)
1520*c87b03e5Sespie && (g->u.common.size < size))
1521*c87b03e5Sespie {
1522*c87b03e5Sespie char oldsize[40];
1523*c87b03e5Sespie char newsize[40];
1524*c87b03e5Sespie
1525*c87b03e5Sespie /* Common block initialized in a previous program unit, which
1526*c87b03e5Sespie effectively freezes its size, but now the program is trying
1527*c87b03e5Sespie to enlarge it. */
1528*c87b03e5Sespie
1529*c87b03e5Sespie sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size);
1530*c87b03e5Sespie sprintf (&newsize[0], "%" ffetargetOffset_f "d", size);
1531*c87b03e5Sespie
1532*c87b03e5Sespie ffebad_start (FFEBAD_COMMON_ENLARGED);
1533*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
1534*c87b03e5Sespie ffebad_string (oldsize);
1535*c87b03e5Sespie ffebad_string (newsize);
1536*c87b03e5Sespie ffebad_string ((g->u.common.size == 1)
1537*c87b03e5Sespie ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1538*c87b03e5Sespie ffebad_string ((size == 1)
1539*c87b03e5Sespie ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1540*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (g->u.common.initt),
1541*c87b03e5Sespie ffelex_token_where_column (g->u.common.initt));
1542*c87b03e5Sespie ffebad_here (1, ffesymbol_where_line (s),
1543*c87b03e5Sespie ffesymbol_where_column (s));
1544*c87b03e5Sespie ffebad_finish ();
1545*c87b03e5Sespie }
1546*c87b03e5Sespie else if ((g->u.common.size != size) && !g->u.common.blank)
1547*c87b03e5Sespie {
1548*c87b03e5Sespie char oldsize[40];
1549*c87b03e5Sespie char newsize[40];
1550*c87b03e5Sespie
1551*c87b03e5Sespie /* Warn about this even if not -pedantic, because putting all
1552*c87b03e5Sespie program units in a single source file is the only way to
1553*c87b03e5Sespie detect this. Apparently UNIX-model linkers neither handle
1554*c87b03e5Sespie nor report when they make a common unit smaller than
1555*c87b03e5Sespie requested, such as when the smaller-declared version is
1556*c87b03e5Sespie initialized and the larger-declared version is not. So
1557*c87b03e5Sespie if people complain about strange overwriting, we can tell
1558*c87b03e5Sespie them to put all their code in a single file and compile
1559*c87b03e5Sespie that way. Warnings about differing sizes must therefore
1560*c87b03e5Sespie always be issued. */
1561*c87b03e5Sespie
1562*c87b03e5Sespie sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size);
1563*c87b03e5Sespie sprintf (&newsize[0], "%" ffetargetOffset_f "d", size);
1564*c87b03e5Sespie
1565*c87b03e5Sespie ffebad_start (FFEBAD_COMMON_DIFF_SIZE);
1566*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
1567*c87b03e5Sespie ffebad_string (oldsize);
1568*c87b03e5Sespie ffebad_string (newsize);
1569*c87b03e5Sespie ffebad_string ((g->u.common.size == 1)
1570*c87b03e5Sespie ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1571*c87b03e5Sespie ffebad_string ((size == 1)
1572*c87b03e5Sespie ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1573*c87b03e5Sespie ffebad_here (0, ffelex_token_where_line (g->t),
1574*c87b03e5Sespie ffelex_token_where_column (g->t));
1575*c87b03e5Sespie ffebad_here (1, ffesymbol_where_line (s),
1576*c87b03e5Sespie ffesymbol_where_column (s));
1577*c87b03e5Sespie ffebad_finish ();
1578*c87b03e5Sespie }
1579*c87b03e5Sespie
1580*c87b03e5Sespie if (size > g->u.common.size)
1581*c87b03e5Sespie {
1582*c87b03e5Sespie g->u.common.size = size;
1583*c87b03e5Sespie return TRUE;
1584*c87b03e5Sespie }
1585*c87b03e5Sespie
1586*c87b03e5Sespie return FALSE;
1587*c87b03e5Sespie }
1588*c87b03e5Sespie
1589*c87b03e5Sespie #endif
1590*c87b03e5Sespie void
ffeglobal_terminate_1()1591*c87b03e5Sespie ffeglobal_terminate_1 ()
1592*c87b03e5Sespie {
1593*c87b03e5Sespie }
1594