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