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 (burley@gnu.org).
5 This file is part of GNU Fortran.
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)
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.
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
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.
44 /* Externals defined here. */
47 /* Simple definitions and enumerations. */
50 /* Internal typedefs. */
53 /* Private include files. */
56 /* Internal structure definitions. */
59 /* Static objects accessed by functions in this module. */
62 static ffenameSpace ffeglobal_filewide_ = NULL;
63 static char *ffeglobal_type_string_[] =
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?"
76 /* Static functions (internal). */
79 /* Internal macros. */
82 /* Call given fn with all globals
84 ffeglobal (*fn)(ffeglobal g);
85 ffeglobal_drive(fn); */
89 ffeglobal_drive (ffeglobal (*fn) ())
91 if (ffeglobal_filewide_ != NULL)
92 ffename_space_drive_global (ffeglobal_filewide_, fn);
96 /* ffeglobal_new_ -- Make new global
100 g = ffeglobal_new_(n); */
102 #if FFEGLOBAL_ENABLED
104 ffeglobal_new_ (ffename n)
110 g = (ffeglobal) malloc_new_ks (malloc_pool_image (), "FFEGLOBAL",
113 #ifdef FFECOM_globalHOOK
114 g->hook = FFECOM_globalNULL;
118 ffename_set_global (n, g);
124 /* ffeglobal_init_1 -- Initialize per file
126 ffeglobal_init_1(); */
131 #if FFEGLOBAL_ENABLED
132 if (ffeglobal_filewide_ != NULL)
133 ffename_space_kill (ffeglobal_filewide_);
134 ffeglobal_filewide_ = ffename_space_new (malloc_pool_image ());
138 /* ffeglobal_init_common -- Initial value specified for common block
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);
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. */
150 ffeglobal_init_common (ffesymbol s, ffelexToken t)
152 #if FFEGLOBAL_ENABLED
155 g = ffesymbol_global (s);
157 if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
159 if (g->type == FFEGLOBAL_typeANY)
162 if (g->tick == ffe_count_2)
167 if (g->u.common.initt != NULL)
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));
177 /* Complain about just one attempt to reinit per program unit, but
178 continue referring back to the first such successful attempt. */
182 if (g->u.common.blank)
184 ffebad_start (FFEBAD_COMMON_BLANK_INIT);
185 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
189 g->u.common.initt = ffelex_token_use (t);
192 g->tick = ffe_count_2;
196 /* ffeglobal_new_common -- New common block
198 ffesymbol s; // the ffesymbol for the new common block
199 ffelexToken t; // the token with the name of the common block
200 bool blank; // TRUE if blank common
201 ffeglobal_new_common(s,t,blank);
203 For back ends where file-wide global symbols are not maintained, does
204 nothing. Otherwise, makes sure this symbol hasn't been seen before or
205 is known as a common block. */
208 ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank)
210 #if FFEGLOBAL_ENABLED
214 if (ffesymbol_global (s) == NULL)
216 n = ffename_find (ffeglobal_filewide_, t);
217 g = ffename_global (n);
221 g = ffesymbol_global (s);
225 if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
228 if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
230 if (g->type == FFEGLOBAL_typeCOMMON)
232 assert (g->u.common.blank == blank);
236 if (ffe_is_globals () || ffe_is_warn_globals ())
238 ffebad_start (ffe_is_globals ()
239 ? FFEBAD_FILEWIDE_ALREADY_SEEN
240 : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
241 ffebad_string (ffelex_token_text (t));
242 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
243 ffebad_here (1, ffelex_token_where_line (g->t),
244 ffelex_token_where_column (g->t));
247 g->type = FFEGLOBAL_typeANY;
254 g = ffeglobal_new_ (n);
255 g->intrinsic = FALSE;
257 else if (g->intrinsic
258 && !g->explicit_intrinsic
259 && ffe_is_warn_globals ())
261 ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
262 ffebad_string (ffelex_token_text (t));
263 ffebad_string ("common block");
264 ffebad_string ("intrinsic");
265 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
266 ffebad_here (1, ffelex_token_where_line (g->t),
267 ffelex_token_where_column (g->t));
270 g->t = ffelex_token_use (t);
271 g->type = FFEGLOBAL_typeCOMMON;
272 g->u.common.have_pad = FALSE;
273 g->u.common.have_save = FALSE;
274 g->u.common.have_size = FALSE;
275 g->u.common.blank = blank;
278 ffesymbol_set_global (s, g);
282 /* ffeglobal_new_progunit_ -- New program unit
284 ffesymbol s; // the ffesymbol for the new unit
285 ffelexToken t; // the token with the name of the unit
286 ffeglobalType type; // the type of the new unit
287 ffeglobal_new_progunit_(s,t,type);
289 For back ends where file-wide global symbols are not maintained, does
290 nothing. Otherwise, makes sure this symbol hasn't been seen before. */
293 ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
295 #if FFEGLOBAL_ENABLED
299 n = ffename_find (ffeglobal_filewide_, t);
300 g = ffename_global (n);
301 if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
305 && ((g->type == FFEGLOBAL_typeMAIN)
306 || (g->type == FFEGLOBAL_typeSUBR)
307 || (g->type == FFEGLOBAL_typeFUNC)
308 || (g->type == FFEGLOBAL_typeBDATA))
309 && g->u.proc.defined)
311 if (ffe_is_globals () || ffe_is_warn_globals ())
313 ffebad_start (ffe_is_globals ()
314 ? FFEBAD_FILEWIDE_ALREADY_SEEN
315 : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
316 ffebad_string (ffelex_token_text (t));
317 ffebad_here (0, ffelex_token_where_line (t),
318 ffelex_token_where_column (t));
319 ffebad_here (1, ffelex_token_where_line (g->t),
320 ffelex_token_where_column (g->t));
323 g->type = FFEGLOBAL_typeANY;
326 && (g->type != FFEGLOBAL_typeNONE)
327 && (g->type != FFEGLOBAL_typeEXT)
328 && (g->type != type))
330 if (ffe_is_globals () || ffe_is_warn_globals ())
332 ffebad_start (ffe_is_globals ()
333 ? FFEBAD_FILEWIDE_DISAGREEMENT
334 : FFEBAD_FILEWIDE_DISAGREEMENT_W);
335 ffebad_string (ffelex_token_text (t));
336 ffebad_string (ffeglobal_type_string_[type]);
337 ffebad_string (ffeglobal_type_string_[g->type]);
338 ffebad_here (0, ffelex_token_where_line (t),
339 ffelex_token_where_column (t));
340 ffebad_here (1, ffelex_token_where_line (g->t),
341 ffelex_token_where_column (g->t));
344 g->type = FFEGLOBAL_typeANY;
350 g = ffeglobal_new_ (n);
351 g->intrinsic = FALSE;
352 g->u.proc.n_args = -1;
353 g->u.proc.other_t = NULL;
355 else if ((ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
356 && ((ffesymbol_basictype (s) != g->u.proc.bt)
357 || (ffesymbol_kindtype (s) != g->u.proc.kt)
358 || ((ffesymbol_size (s) != FFETARGET_charactersizeNONE)
359 && (ffesymbol_size (s) != g->u.proc.sz))))
361 if (ffe_is_globals () || ffe_is_warn_globals ())
363 ffebad_start (ffe_is_globals ()
364 ? FFEBAD_FILEWIDE_TYPE_MISMATCH
365 : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
366 ffebad_string (ffelex_token_text (t));
367 ffebad_here (0, ffelex_token_where_line (t),
368 ffelex_token_where_column (t));
369 ffebad_here (1, ffelex_token_where_line (g->t),
370 ffelex_token_where_column (g->t));
373 g->type = FFEGLOBAL_typeANY;
377 && !g->explicit_intrinsic
378 && ffe_is_warn_globals ())
380 ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
381 ffebad_string (ffelex_token_text (t));
382 ffebad_string ("global");
383 ffebad_string ("intrinsic");
384 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
385 ffebad_here (1, ffelex_token_where_line (g->t),
386 ffelex_token_where_column (g->t));
389 g->t = ffelex_token_use (t);
391 || (g->u.proc.bt == FFEINFO_basictypeNONE)
392 || (g->u.proc.kt == FFEINFO_kindtypeNONE))
394 g->u.proc.bt = ffesymbol_basictype (s);
395 g->u.proc.kt = ffesymbol_kindtype (s);
396 g->u.proc.sz = ffesymbol_size (s);
398 g->tick = ffe_count_2;
400 && (g->type != type))
401 g->u.proc.n_args = -1;
403 g->u.proc.defined = TRUE;
406 ffesymbol_set_global (s, g);
410 /* ffeglobal_pad_common -- Check initial padding of common area
412 ffesymbol s; // the common area
413 ffetargetAlign pad; // the initial padding
414 ffeglobal_pad_common(s,pad,ffesymbol_where_line(s),
415 ffesymbol_where_column(s));
417 In global-enabled mode, make sure the padding agrees with any existing
418 padding established for the common area, otherwise complain.
419 In global-disabled mode, warn about nonzero padding. */
422 ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl,
425 #if FFEGLOBAL_ENABLED
428 g = ffesymbol_global (s);
429 if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
430 return; /* Let someone else catch this! */
431 if (g->type == FFEGLOBAL_typeANY)
434 if (!g->u.common.have_pad)
436 g->u.common.have_pad = TRUE;
437 g->u.common.pad = pad;
438 g->u.common.pad_where_line = ffewhere_line_use (wl);
439 g->u.common.pad_where_col = ffewhere_column_use (wc);
443 if (g->u.common.pad != pad)
448 sprintf (&padding_1[0], "%" ffetargetAlign_f "u", pad);
449 sprintf (&padding_2[0], "%" ffetargetAlign_f "u", g->u.common.pad);
450 ffebad_start (FFEBAD_COMMON_DIFF_PAD);
451 ffebad_string (ffesymbol_text (s));
452 ffebad_string (padding_1);
453 ffebad_here (0, wl, wc);
454 ffebad_string (padding_2);
455 ffebad_string ((pad == 1)
456 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
457 ffebad_string ((g->u.common.pad == 1)
458 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
459 ffebad_here (1, g->u.common.pad_where_line, g->u.common.pad_where_col);
466 { /* Warn about initial padding in common area. */
469 sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
470 ffebad_start (FFEBAD_COMMON_INIT_PAD);
471 ffebad_string (ffesymbol_text (s));
472 ffebad_string (padding);
473 ffebad_string ((pad == 1)
474 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
475 ffebad_here (0, wl, wc);
480 /* Collect info for a global's argument. */
483 ffeglobal_proc_def_arg (ffesymbol s, int argno, char *name, ffeglobalArgSummary as,
484 ffeinfoBasictype bt, ffeinfoKindtype kt,
487 ffeglobal g = ffesymbol_global (s);
488 ffeglobalArgInfo_ ai;
492 if (g->type == FFEGLOBAL_typeANY)
495 assert (g->u.proc.n_args >= 0);
497 if (argno >= g->u.proc.n_args)
498 return; /* Already complained about this discrepancy. */
500 ai = &g->u.proc.arg_info[argno];
502 /* Maybe warn about previous references. */
505 && ffe_is_warn_globals ())
513 case FFEGLOBAL_argsummaryREF:
514 if ((ai->as != FFEGLOBAL_argsummaryREF)
515 && (ai->as != FFEGLOBAL_argsummaryNONE)
516 && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */
517 || (ai->bt != FFEINFO_basictypeCHARACTER)
521 refwhy = "passed by reference";
525 case FFEGLOBAL_argsummaryDESCR:
526 if ((ai->as != FFEGLOBAL_argsummaryDESCR)
527 && (ai->as != FFEGLOBAL_argsummaryNONE)
528 && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */
529 || (bt != FFEINFO_basictypeCHARACTER)
533 refwhy = "passed by descriptor";
537 case FFEGLOBAL_argsummaryPROC:
538 if ((ai->as != FFEGLOBAL_argsummaryPROC)
539 && (ai->as != FFEGLOBAL_argsummarySUBR)
540 && (ai->as != FFEGLOBAL_argsummaryFUNC)
541 && (ai->as != FFEGLOBAL_argsummaryNONE))
544 refwhy = "a procedure";
548 case FFEGLOBAL_argsummarySUBR:
549 if ((ai->as != FFEGLOBAL_argsummaryPROC)
550 && (ai->as != FFEGLOBAL_argsummarySUBR)
551 && (ai->as != FFEGLOBAL_argsummaryNONE))
554 refwhy = "a subroutine";
558 case FFEGLOBAL_argsummaryFUNC:
559 if ((ai->as != FFEGLOBAL_argsummaryPROC)
560 && (ai->as != FFEGLOBAL_argsummaryFUNC)
561 && (ai->as != FFEGLOBAL_argsummaryNONE))
564 refwhy = "a function";
568 case FFEGLOBAL_argsummaryALTRTN:
569 if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
570 && (ai->as != FFEGLOBAL_argsummaryNONE))
573 refwhy = "an alternate-return label";
581 if ((refwhy != NULL) && (defwhy == NULL))
583 /* Fill in the def info. */
587 case FFEGLOBAL_argsummaryNONE:
591 case FFEGLOBAL_argsummaryVAL:
592 defwhy = "passed by value";
595 case FFEGLOBAL_argsummaryREF:
596 defwhy = "passed by reference";
599 case FFEGLOBAL_argsummaryDESCR:
600 defwhy = "passed by descriptor";
603 case FFEGLOBAL_argsummaryPROC:
604 defwhy = "a procedure";
607 case FFEGLOBAL_argsummarySUBR:
608 defwhy = "a subroutine";
611 case FFEGLOBAL_argsummaryFUNC:
612 defwhy = "a function";
615 case FFEGLOBAL_argsummaryALTRTN:
616 defwhy = "an alternate-return label";
619 case FFEGLOBAL_argsummaryPTR:
620 defwhy = "a pointer";
630 && (bt != FFEINFO_basictypeHOLLERITH)
631 && (bt != FFEINFO_basictypeTYPELESS)
632 && (bt != FFEINFO_basictypeNONE)
633 && (ai->bt != FFEINFO_basictypeHOLLERITH)
634 && (ai->bt != FFEINFO_basictypeTYPELESS)
635 && (ai->bt != FFEINFO_basictypeNONE))
640 && ((bt != FFEINFO_basictypeREAL)
641 || (ai->bt != FFEINFO_basictypeCOMPLEX))
642 && ((bt != FFEINFO_basictypeCOMPLEX)
643 || (ai->bt != FFEINFO_basictypeREAL)))
645 warn = TRUE; /* We can cope with these differences. */
647 defwhy = "some other type";
650 if (!warn && (kt != ai->kt))
653 refwhy = "one precision";
654 defwhy = "some other precision";
663 sprintf (&num[0], "%d", argno + 1);
666 if (strlen (name) < 30)
667 sprintf (&num[0], "%d (named `%s')", argno + 1, name);
669 sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, name);
671 ffebad_start (FFEBAD_FILEWIDE_ARG_W);
672 ffebad_string (ffesymbol_text (s));
674 ffebad_string (refwhy);
675 ffebad_string (defwhy);
676 ffebad_here (0, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t));
677 ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
682 /* Define this argument. */
685 ffelex_token_kill (ai->t);
686 if ((as != FFEGLOBAL_argsummaryPROC)
688 ai->as = as; /* Otherwise leave SUBR/FUNC info intact. */
689 ai->t = ffelex_token_use (g->t);
694 ai->name = malloc_new_ks (malloc_pool_image (),
695 "ffeglobalArgInfo_ name",
697 strcpy (ai->name, name);
704 /* Collect info on #args a global accepts. */
707 ffeglobal_proc_def_nargs (ffesymbol s, int n_args)
709 ffeglobal g = ffesymbol_global (s);
713 if (g->type == FFEGLOBAL_typeANY)
716 if (g->u.proc.n_args >= 0)
718 if (g->u.proc.n_args == n_args)
721 if (ffe_is_warn_globals ())
723 ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
724 ffebad_string (ffesymbol_text (s));
725 if (g->u.proc.n_args > n_args)
726 ffebad_string ("few");
728 ffebad_string ("many");
729 ffebad_here (0, ffelex_token_where_line (g->u.proc.other_t),
730 ffelex_token_where_column (g->u.proc.other_t));
731 ffebad_here (1, ffelex_token_where_line (g->t),
732 ffelex_token_where_column (g->t));
737 /* This is new info we can use in cross-checking future references
738 and a possible future definition. */
740 g->u.proc.n_args = n_args;
741 g->u.proc.other_t = NULL; /* No other reference yet. */
745 g->u.proc.arg_info = NULL;
750 = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (),
752 n_args * sizeof (g->u.proc.arg_info[0]));
754 g->u.proc.arg_info[n_args].t = NULL;
757 /* Verify that the info for a global's argument is valid. */
760 ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as,
761 ffeinfoBasictype bt, ffeinfoKindtype kt,
762 bool array, ffelexToken t)
764 ffeglobal g = ffesymbol_global (s);
765 ffeglobalArgInfo_ ai;
769 if (g->type == FFEGLOBAL_typeANY)
772 assert (g->u.proc.n_args >= 0);
774 if (argno >= g->u.proc.n_args)
775 return TRUE; /* Already complained about this discrepancy. */
777 ai = &g->u.proc.arg_info[argno];
779 /* Warn about previous references. */
790 case FFEGLOBAL_argsummaryNONE:
791 if (g->u.proc.defined)
795 defwhy = "not optional";
799 case FFEGLOBAL_argsummaryVAL:
800 if (ai->as != FFEGLOBAL_argsummaryVAL)
803 refwhy = "passed by value";
807 case FFEGLOBAL_argsummaryREF:
808 if ((ai->as != FFEGLOBAL_argsummaryREF)
809 && (ai->as != FFEGLOBAL_argsummaryNONE)
810 && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */
811 || (ai->bt != FFEINFO_basictypeCHARACTER)
815 refwhy = "passed by reference";
819 case FFEGLOBAL_argsummaryDESCR:
820 if ((ai->as != FFEGLOBAL_argsummaryDESCR)
821 && (ai->as != FFEGLOBAL_argsummaryNONE)
822 && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */
823 || (bt != FFEINFO_basictypeCHARACTER)
827 refwhy = "passed by descriptor";
831 case FFEGLOBAL_argsummaryPROC:
832 if ((ai->as != FFEGLOBAL_argsummaryPROC)
833 && (ai->as != FFEGLOBAL_argsummarySUBR)
834 && (ai->as != FFEGLOBAL_argsummaryFUNC)
835 && (ai->as != FFEGLOBAL_argsummaryNONE))
838 refwhy = "a procedure";
842 case FFEGLOBAL_argsummarySUBR:
843 if ((ai->as != FFEGLOBAL_argsummaryPROC)
844 && (ai->as != FFEGLOBAL_argsummarySUBR)
845 && (ai->as != FFEGLOBAL_argsummaryNONE))
848 refwhy = "a subroutine";
852 case FFEGLOBAL_argsummaryFUNC:
853 if ((ai->as != FFEGLOBAL_argsummaryPROC)
854 && (ai->as != FFEGLOBAL_argsummaryFUNC)
855 && (ai->as != FFEGLOBAL_argsummaryNONE))
858 refwhy = "a function";
862 case FFEGLOBAL_argsummaryALTRTN:
863 if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
864 && (ai->as != FFEGLOBAL_argsummaryNONE))
867 refwhy = "an alternate-return label";
871 case FFEGLOBAL_argsummaryPTR:
872 if ((ai->as != FFEGLOBAL_argsummaryPTR)
873 && (ai->as != FFEGLOBAL_argsummaryNONE))
876 refwhy = "a pointer";
884 if ((refwhy != NULL) && (defwhy == NULL))
886 /* Fill in the def info. */
890 case FFEGLOBAL_argsummaryNONE:
894 case FFEGLOBAL_argsummaryVAL:
895 defwhy = "passed by value";
898 case FFEGLOBAL_argsummaryREF:
899 defwhy = "passed by reference";
902 case FFEGLOBAL_argsummaryDESCR:
903 defwhy = "passed by descriptor";
906 case FFEGLOBAL_argsummaryPROC:
907 defwhy = "a procedure";
910 case FFEGLOBAL_argsummarySUBR:
911 defwhy = "a subroutine";
914 case FFEGLOBAL_argsummaryFUNC:
915 defwhy = "a function";
918 case FFEGLOBAL_argsummaryALTRTN:
919 defwhy = "an alternate-return label";
922 case FFEGLOBAL_argsummaryPTR:
923 defwhy = "a pointer";
933 && (bt != FFEINFO_basictypeHOLLERITH)
934 && (bt != FFEINFO_basictypeTYPELESS)
935 && (bt != FFEINFO_basictypeNONE)
936 && (ai->bt != FFEINFO_basictypeHOLLERITH)
937 && (ai->bt != FFEINFO_basictypeNONE)
938 && (ai->bt != FFEINFO_basictypeTYPELESS))
943 && ((bt != FFEINFO_basictypeREAL)
944 || (ai->bt != FFEINFO_basictypeCOMPLEX))
945 && ((bt != FFEINFO_basictypeCOMPLEX)
946 || (ai->bt != FFEINFO_basictypeREAL)))
948 if (((bt == FFEINFO_basictypeINTEGER)
949 && (ai->bt == FFEINFO_basictypeLOGICAL))
950 || ((bt == FFEINFO_basictypeLOGICAL)
951 && (ai->bt == FFEINFO_basictypeINTEGER)))
952 warn = TRUE; /* We can cope with these differences. */
956 defwhy = "some other type";
959 if (!fail && !warn && (kt != ai->kt))
962 refwhy = "one precision";
963 defwhy = "some other precision";
967 if (fail && ! g->u.proc.defined)
969 /* No point failing if we're worried only about invocations. */
974 if (fail && ! ffe_is_globals ())
980 if (fail || (warn && ffe_is_warn_globals ()))
984 if (ai->name == NULL)
985 sprintf (&num[0], "%d", argno + 1);
988 if (strlen (ai->name) < 30)
989 sprintf (&num[0], "%d (named `%s')", argno + 1, ai->name);
991 sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, ai->name);
993 ffebad_start (fail ? FFEBAD_FILEWIDE_ARG : FFEBAD_FILEWIDE_ARG_W);
994 ffebad_string (ffesymbol_text (s));
996 ffebad_string (refwhy);
997 ffebad_string (defwhy);
998 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
999 ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
1001 return (fail ? FALSE : TRUE);
1008 /* Define this argument. */
1011 ffelex_token_kill (ai->t);
1012 if ((as != FFEGLOBAL_argsummaryPROC)
1015 ai->t = ffelex_token_use (g->t);
1024 ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t)
1026 ffeglobal g = ffesymbol_global (s);
1030 if (g->type == FFEGLOBAL_typeANY)
1033 if (g->u.proc.n_args >= 0)
1035 if (g->u.proc.n_args == n_args)
1038 if (g->u.proc.defined && ffe_is_globals ())
1040 ffebad_start (FFEBAD_FILEWIDE_NARGS);
1041 ffebad_string (ffesymbol_text (s));
1042 if (g->u.proc.n_args > n_args)
1043 ffebad_string ("few");
1045 ffebad_string ("many");
1046 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1047 ffebad_here (1, ffelex_token_where_line (g->t),
1048 ffelex_token_where_column (g->t));
1053 if (ffe_is_warn_globals ())
1055 ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
1056 ffebad_string (ffesymbol_text (s));
1057 if (g->u.proc.n_args > n_args)
1058 ffebad_string ("few");
1060 ffebad_string ("many");
1061 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1062 ffebad_here (1, ffelex_token_where_line (g->t),
1063 ffelex_token_where_column (g->t));
1067 return TRUE; /* Don't replace the info we already have. */
1070 /* This is new info we can use in cross-checking future references
1071 and a possible future definition. */
1073 g->u.proc.n_args = n_args;
1074 g->u.proc.other_t = ffelex_token_use (t);
1076 /* Make this "the" place we found the global, since it has the most info. */
1079 ffelex_token_kill (g->t);
1080 g->t = ffelex_token_use (t);
1084 g->u.proc.arg_info = NULL;
1089 = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (),
1090 "ffeglobalArgInfo_",
1091 n_args * sizeof (g->u.proc.arg_info[0]));
1092 while (n_args-- > 0)
1093 g->u.proc.arg_info[n_args].t = NULL;
1098 /* Return a global for a promoted symbol (one that has heretofore
1099 been assumed to be local, but since discovered to be global). */
1102 ffeglobal_promoted (ffesymbol s)
1104 #if FFEGLOBAL_ENABLED
1108 assert (ffesymbol_global (s) == NULL);
1110 n = ffename_find (ffeglobal_filewide_, ffename_token (ffesymbol_name (s)));
1111 g = ffename_global (n);
1119 /* Register a reference to an intrinsic. Such a reference is always
1120 valid, though a warning might be in order if the same name has
1121 already been used for a global. */
1124 ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit)
1126 #if FFEGLOBAL_ENABLED
1130 if (ffesymbol_global (s) == NULL)
1132 n = ffename_find (ffeglobal_filewide_, t);
1133 g = ffename_global (n);
1137 g = ffesymbol_global (s);
1141 if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
1144 if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
1148 && ffe_is_warn_globals ())
1150 ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
1151 ffebad_string (ffelex_token_text (t));
1152 ffebad_string ("intrinsic");
1153 ffebad_string ("global");
1154 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1155 ffebad_here (1, ffelex_token_where_line (g->t),
1156 ffelex_token_where_column (g->t));
1164 g = ffeglobal_new_ (n);
1165 g->tick = ffe_count_2;
1166 g->type = FFEGLOBAL_typeNONE;
1167 g->intrinsic = TRUE;
1168 g->explicit_intrinsic = explicit;
1169 g->t = ffelex_token_use (t);
1171 else if (g->intrinsic
1172 && (explicit != g->explicit_intrinsic)
1173 && (g->tick != ffe_count_2)
1174 && ffe_is_warn_globals ())
1176 ffebad_start (FFEBAD_INTRINSIC_EXPIMP);
1177 ffebad_string (ffelex_token_text (t));
1178 ffebad_string (explicit ? "explicit" : "implicit");
1179 ffebad_string (explicit ? "implicit" : "explicit");
1180 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1181 ffebad_here (1, ffelex_token_where_line (g->t),
1182 ffelex_token_where_column (g->t));
1187 g->intrinsic = TRUE;
1189 g->explicit_intrinsic = TRUE;
1191 ffesymbol_set_global (s, g);
1195 /* Register a reference to a global. Returns TRUE if the reference
1199 ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
1201 #if FFEGLOBAL_ENABLED
1205 /* It is never really _known_ that an EXTERNAL statement
1206 names a BLOCK DATA by just looking at the program unit,
1207 so override a different notion here. */
1208 if (type == FFEGLOBAL_typeBDATA)
1209 type = FFEGLOBAL_typeEXT;
1211 g = ffesymbol_global (s);
1214 n = ffename_find (ffeglobal_filewide_, t);
1215 g = ffename_global (n);
1217 ffesymbol_set_global (s, g);
1220 if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
1224 && (g->type != FFEGLOBAL_typeNONE)
1225 && (g->type != type)
1226 && (g->type != FFEGLOBAL_typeEXT)
1227 && (type != FFEGLOBAL_typeEXT))
1229 if ((((type == FFEGLOBAL_typeBDATA)
1230 && (g->type != FFEGLOBAL_typeCOMMON))
1231 || ((g->type == FFEGLOBAL_typeBDATA)
1232 && (type != FFEGLOBAL_typeCOMMON)
1233 && ! g->u.proc.defined)))
1235 #if 0 /* This is likely to just annoy people. */
1236 if (ffe_is_warn_globals ())
1238 ffebad_start (FFEBAD_FILEWIDE_TIFF);
1239 ffebad_string (ffelex_token_text (t));
1240 ffebad_string (ffeglobal_type_string_[type]);
1241 ffebad_string (ffeglobal_type_string_[g->type]);
1242 ffebad_here (0, ffelex_token_where_line (t),
1243 ffelex_token_where_column (t));
1244 ffebad_here (1, ffelex_token_where_line (g->t),
1245 ffelex_token_where_column (g->t));
1250 else if (ffe_is_globals ())
1252 ffebad_start (FFEBAD_FILEWIDE_DISAGREEMENT);
1253 ffebad_string (ffelex_token_text (t));
1254 ffebad_string (ffeglobal_type_string_[type]);
1255 ffebad_string (ffeglobal_type_string_[g->type]);
1256 ffebad_here (0, ffelex_token_where_line (t),
1257 ffelex_token_where_column (t));
1258 ffebad_here (1, ffelex_token_where_line (g->t),
1259 ffelex_token_where_column (g->t));
1261 g->type = FFEGLOBAL_typeANY;
1264 else if (ffe_is_warn_globals ())
1266 ffebad_start (FFEBAD_FILEWIDE_DISAGREEMENT_W);
1267 ffebad_string (ffelex_token_text (t));
1268 ffebad_string (ffeglobal_type_string_[type]);
1269 ffebad_string (ffeglobal_type_string_[g->type]);
1270 ffebad_here (0, ffelex_token_where_line (t),
1271 ffelex_token_where_column (t));
1272 ffebad_here (1, ffelex_token_where_line (g->t),
1273 ffelex_token_where_column (g->t));
1275 g->type = FFEGLOBAL_typeANY;
1281 && (type == FFEGLOBAL_typeFUNC))
1283 /* If just filling in this function's type, do so. */
1284 if ((g->tick == ffe_count_2)
1285 && (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
1286 && (ffesymbol_kindtype (s) != FFEINFO_kindtypeNONE))
1288 g->u.proc.bt = ffesymbol_basictype (s);
1289 g->u.proc.kt = ffesymbol_kindtype (s);
1290 g->u.proc.sz = ffesymbol_size (s);
1292 /* Else, make sure there is type agreement. */
1293 else if ((g->u.proc.bt != FFEINFO_basictypeNONE)
1294 && (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
1295 && ((ffesymbol_basictype (s) != g->u.proc.bt)
1296 || (ffesymbol_kindtype (s) != g->u.proc.kt)
1297 || ((ffesymbol_size (s) != g->u.proc.sz)
1298 && g->u.proc.defined
1299 && (g->u.proc.sz != FFETARGET_charactersizeNONE))))
1301 if (ffe_is_globals ())
1303 ffebad_start (FFEBAD_FILEWIDE_TYPE_MISMATCH);
1304 ffebad_string (ffelex_token_text (t));
1305 ffebad_here (0, ffelex_token_where_line (t),
1306 ffelex_token_where_column (t));
1307 ffebad_here (1, ffelex_token_where_line (g->t),
1308 ffelex_token_where_column (g->t));
1310 g->type = FFEGLOBAL_typeANY;
1313 if (ffe_is_warn_globals ())
1315 ffebad_start (FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
1316 ffebad_string (ffelex_token_text (t));
1317 ffebad_here (0, ffelex_token_where_line (t),
1318 ffelex_token_where_column (t));
1319 ffebad_here (1, ffelex_token_where_line (g->t),
1320 ffelex_token_where_column (g->t));
1323 g->type = FFEGLOBAL_typeANY;
1330 g = ffeglobal_new_ (n);
1331 g->t = ffelex_token_use (t);
1332 g->tick = ffe_count_2;
1333 g->intrinsic = FALSE;
1335 g->u.proc.defined = FALSE;
1336 g->u.proc.bt = ffesymbol_basictype (s);
1337 g->u.proc.kt = ffesymbol_kindtype (s);
1338 g->u.proc.sz = ffesymbol_size (s);
1339 g->u.proc.n_args = -1;
1340 ffesymbol_set_global (s, g);
1342 else if (g->intrinsic
1343 && !g->explicit_intrinsic
1344 && (g->tick != ffe_count_2)
1345 && ffe_is_warn_globals ())
1347 ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
1348 ffebad_string (ffelex_token_text (t));
1349 ffebad_string ("global");
1350 ffebad_string ("intrinsic");
1351 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1352 ffebad_here (1, ffelex_token_where_line (g->t),
1353 ffelex_token_where_column (g->t));
1357 if ((g->type != type)
1358 && (type != FFEGLOBAL_typeEXT))
1360 /* We've learned more, so point to where we learned it. */
1361 g->t = ffelex_token_use (t);
1363 #ifdef FFECOM_globalHOOK
1364 g->hook = FFECOM_globalNULL; /* Discard previous _DECL. */
1366 g->u.proc.n_args = -1;
1373 /* ffeglobal_save_common -- Check SAVE status of common area
1375 ffesymbol s; // the common area
1376 bool save; // TRUE if SAVEd, FALSE otherwise
1377 ffeglobal_save_common(s,save,ffesymbol_where_line(s),
1378 ffesymbol_where_column(s));
1380 In global-enabled mode, make sure the save info agrees with any existing
1381 info established for the common area, otherwise complain.
1382 In global-disabled mode, do nothing. */
1385 ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl,
1388 #if FFEGLOBAL_ENABLED
1391 g = ffesymbol_global (s);
1392 if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
1393 return; /* Let someone else catch this! */
1394 if (g->type == FFEGLOBAL_typeANY)
1397 if (!g->u.common.have_save)
1399 g->u.common.have_save = TRUE;
1400 g->u.common.save = save;
1401 g->u.common.save_where_line = ffewhere_line_use (wl);
1402 g->u.common.save_where_col = ffewhere_column_use (wc);
1406 if ((g->u.common.save != save) && ffe_is_pedantic ())
1408 ffebad_start (FFEBAD_COMMON_DIFF_SAVE);
1409 ffebad_string (ffesymbol_text (s));
1410 ffebad_here (save ? 0 : 1, wl, wc);
1411 ffebad_here (save ? 1 : 0, g->u.common.pad_where_line, g->u.common.pad_where_col);
1418 /* ffeglobal_size_common -- Establish size of COMMON area
1420 ffesymbol s; // the common area
1421 long size; // size in units
1422 if (ffeglobal_size_common(s,size)) // new size is largest seen
1424 In global-enabled mode, set the size if it current size isn't known or is
1425 smaller than new size, and for non-blank common, complain if old size
1426 is different from new. Return TRUE if the new size is the largest seen
1427 for this COMMON area (or if no size was known for it previously).
1428 In global-disabled mode, do nothing. */
1430 #if FFEGLOBAL_ENABLED
1432 ffeglobal_size_common (ffesymbol s, long size)
1436 g = ffesymbol_global (s);
1437 if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
1439 if (g->type == FFEGLOBAL_typeANY)
1442 if (!g->u.common.have_size)
1444 g->u.common.have_size = TRUE;
1445 g->u.common.size = size;
1449 if ((g->u.common.size < size) && (g->tick > 0) && (g->tick < ffe_count_2))
1454 sprintf (&oldsize[0], "%ld", g->u.common.size);
1455 sprintf (&newsize[0], "%ld", size);
1457 ffebad_start (FFEBAD_COMMON_ENLARGED);
1458 ffebad_string (ffesymbol_text (s));
1459 ffebad_string (oldsize);
1460 ffebad_string (newsize);
1461 ffebad_string ((g->u.common.size == 1)
1462 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1463 ffebad_string ((size == 1)
1464 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1465 ffebad_here (0, ffelex_token_where_line (g->u.common.initt),
1466 ffelex_token_where_column (g->u.common.initt));
1467 ffebad_here (1, ffesymbol_where_line (s),
1468 ffesymbol_where_column (s));
1471 else if ((g->u.common.size != size) && !g->u.common.blank)
1476 /* Warn about this even if not -pedantic, because putting all
1477 program units in a single source file is the only way to
1478 detect this. Apparently UNIX-model linkers neither handle
1479 nor report when they make a common unit smaller than
1480 requested, such as when the smaller-declared version is
1481 initialized and the larger-declared version is not. So
1482 if people complain about strange overwriting, we can tell
1483 them to put all their code in a single file and compile
1484 that way. Warnings about differing sizes must therefore
1485 always be issued. */
1487 sprintf (&oldsize[0], "%ld", g->u.common.size);
1488 sprintf (&newsize[0], "%ld", size);
1490 ffebad_start (FFEBAD_COMMON_DIFF_SIZE);
1491 ffebad_string (ffesymbol_text (s));
1492 ffebad_string (oldsize);
1493 ffebad_string (newsize);
1494 ffebad_string ((g->u.common.size == 1)
1495 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1496 ffebad_string ((size == 1)
1497 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1498 ffebad_here (0, ffelex_token_where_line (g->t),
1499 ffelex_token_where_column (g->t));
1500 ffebad_here (1, ffesymbol_where_line (s),
1501 ffesymbol_where_column (s));
1505 if (size > g->u.common.size)
1507 g->u.common.size = size;
1515 ffeglobal_terminate_1 ()