/* global.c -- Implementation File (module.c template V1.0) Copyright (C) 1995, 1997 Free Software Foundation, Inc. Contributed by James Craig Burley. This file is part of GNU Fortran. GNU Fortran is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Fortran is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Fortran; see the file COPYING. If not, write to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. Related Modules: Description: Manages information kept across individual program units within a single source file. This includes reporting errors when a name is defined multiple times (for example, two program units named FOO) and when a COMMON block is given initial data in more than one program unit. Modifications: */ /* Include files. */ #include "proj.h" #include "global.h" #include "info.h" #include "lex.h" #include "malloc.h" #include "name.h" #include "symbol.h" #include "top.h" /* Externals defined here. */ /* Simple definitions and enumerations. */ /* Internal typedefs. */ /* Private include files. */ /* Internal structure definitions. */ /* Static objects accessed by functions in this module. */ #if FFEGLOBAL_ENABLED static ffenameSpace ffeglobal_filewide_ = NULL; static char *ffeglobal_type_string_[] = { [FFEGLOBAL_typeNONE] "??", [FFEGLOBAL_typeMAIN] "main program", [FFEGLOBAL_typeEXT] "external", [FFEGLOBAL_typeSUBR] "subroutine", [FFEGLOBAL_typeFUNC] "function", [FFEGLOBAL_typeBDATA] "block data", [FFEGLOBAL_typeCOMMON] "common block", [FFEGLOBAL_typeANY] "?any?" }; #endif /* Static functions (internal). */ /* Internal macros. */ /* Call given fn with all globals ffeglobal (*fn)(ffeglobal g); ffeglobal_drive(fn); */ #if FFEGLOBAL_ENABLED void ffeglobal_drive (ffeglobal (*fn) ()) { if (ffeglobal_filewide_ != NULL) ffename_space_drive_global (ffeglobal_filewide_, fn); } #endif /* ffeglobal_new_ -- Make new global ffename n; ffeglobal g; g = ffeglobal_new_(n); */ #if FFEGLOBAL_ENABLED static ffeglobal ffeglobal_new_ (ffename n) { ffeglobal g; assert (n != NULL); g = (ffeglobal) malloc_new_ks (malloc_pool_image (), "FFEGLOBAL", sizeof (*g)); g->n = n; #ifdef FFECOM_globalHOOK g->hook = FFECOM_globalNULL; #endif g->tick = 0; ffename_set_global (n, g); return g; } #endif /* ffeglobal_init_1 -- Initialize per file ffeglobal_init_1(); */ void ffeglobal_init_1 () { #if FFEGLOBAL_ENABLED if (ffeglobal_filewide_ != NULL) ffename_space_kill (ffeglobal_filewide_); ffeglobal_filewide_ = ffename_space_new (malloc_pool_image ()); #endif } /* ffeglobal_init_common -- Initial value specified for common block ffesymbol s; // the ffesymbol for the common block ffelexToken t; // the token with the point of initialization ffeglobal_init_common(s,t); For back ends where file-wide global symbols are not maintained, does nothing. Otherwise, makes sure this common block hasn't already been initialized in a previous program unit, and flag that it's been initialized in this one. */ void ffeglobal_init_common (ffesymbol s, ffelexToken t) { #if FFEGLOBAL_ENABLED ffeglobal g; g = ffesymbol_global (s); if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON)) return; if (g->type == FFEGLOBAL_typeANY) return; if (g->tick == ffe_count_2) return; if (g->tick != 0) { if (g->u.common.initt != NULL) { ffebad_start (FFEBAD_COMMON_ALREADY_INIT); ffebad_string (ffesymbol_text (s)); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->u.common.initt), ffelex_token_where_column (g->u.common.initt)); ffebad_finish (); } /* Complain about just one attempt to reinit per program unit, but continue referring back to the first such successful attempt. */ } else { if (g->u.common.blank) { /* Not supposed to initialize blank common, though it works. */ ffebad_start (FFEBAD_COMMON_BLANK_INIT); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } g->u.common.initt = ffelex_token_use (t); } g->tick = ffe_count_2; #endif } /* ffeglobal_new_common -- New common block ffesymbol s; // the ffesymbol for the new common block ffelexToken t; // the token with the name of the common block bool blank; // TRUE if blank common ffeglobal_new_common(s,t,blank); For back ends where file-wide global symbols are not maintained, does nothing. Otherwise, makes sure this symbol hasn't been seen before or is known as a common block. */ void ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank) { #if FFEGLOBAL_ENABLED ffename n; ffeglobal g; if (ffesymbol_global (s) == NULL) { n = ffename_find (ffeglobal_filewide_, t); g = ffename_global (n); } else { g = ffesymbol_global (s); n = NULL; } if ((g != NULL) && (g->type == FFEGLOBAL_typeANY)) return; if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE)) { if (g->type == FFEGLOBAL_typeCOMMON) { /* The names match, so the "blankness" should match too! */ assert (g->u.common.blank == blank); } else { /* This global name has already been established, but as something other than a common block. */ if (ffe_is_globals () || ffe_is_warn_globals ()) { ffebad_start (ffe_is_globals () ? FFEBAD_FILEWIDE_ALREADY_SEEN : FFEBAD_FILEWIDE_ALREADY_SEEN_W); ffebad_string (ffelex_token_text (t)); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } g->type = FFEGLOBAL_typeANY; } } else { if (g == NULL) { g = ffeglobal_new_ (n); g->intrinsic = FALSE; } else if (g->intrinsic && !g->explicit_intrinsic && ffe_is_warn_globals ()) { /* Common name previously used as intrinsic. Though it works, warn, because the intrinsic reference might have been intended as a ref to an external procedure, but g77's vast list of intrinsics happened to snarf the name. */ ffebad_start (FFEBAD_INTRINSIC_GLOBAL); ffebad_string (ffelex_token_text (t)); ffebad_string ("common block"); ffebad_string ("intrinsic"); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } g->t = ffelex_token_use (t); g->type = FFEGLOBAL_typeCOMMON; g->u.common.have_pad = FALSE; g->u.common.have_save = FALSE; g->u.common.have_size = FALSE; g->u.common.blank = blank; } ffesymbol_set_global (s, g); #endif } /* ffeglobal_new_progunit_ -- New program unit ffesymbol s; // the ffesymbol for the new unit ffelexToken t; // the token with the name of the unit ffeglobalType type; // the type of the new unit ffeglobal_new_progunit_(s,t,type); For back ends where file-wide global symbols are not maintained, does nothing. Otherwise, makes sure this symbol hasn't been seen before. */ void ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type) { #if FFEGLOBAL_ENABLED ffename n; ffeglobal g; n = ffename_find (ffeglobal_filewide_, t); g = ffename_global (n); if ((g != NULL) && (g->type == FFEGLOBAL_typeANY)) return; if ((g != NULL) && ((g->type == FFEGLOBAL_typeMAIN) || (g->type == FFEGLOBAL_typeSUBR) || (g->type == FFEGLOBAL_typeFUNC) || (g->type == FFEGLOBAL_typeBDATA)) && g->u.proc.defined) { /* This program unit has already been defined. */ if (ffe_is_globals () || ffe_is_warn_globals ()) { ffebad_start (ffe_is_globals () ? FFEBAD_FILEWIDE_ALREADY_SEEN : FFEBAD_FILEWIDE_ALREADY_SEEN_W); ffebad_string (ffelex_token_text (t)); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } g->type = FFEGLOBAL_typeANY; } else if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE) && (g->type != FFEGLOBAL_typeEXT) && (g->type != type)) { /* A reference to this program unit has been seen, but its context disagrees about the new definition regarding what kind of program unit it is. (E.g. `call foo' followed by `function foo'.) But `external foo' alone doesn't mean disagreement with either a function or subroutine, though g77 normally interprets it as a request to force-load a block data program unit by that name (to cope with libs). */ if (ffe_is_globals () || ffe_is_warn_globals ()) { ffebad_start (ffe_is_globals () ? FFEBAD_FILEWIDE_DISAGREEMENT : FFEBAD_FILEWIDE_DISAGREEMENT_W); ffebad_string (ffelex_token_text (t)); ffebad_string (ffeglobal_type_string_[type]); ffebad_string (ffeglobal_type_string_[g->type]); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } g->type = FFEGLOBAL_typeANY; } else { if (g == NULL) { g = ffeglobal_new_ (n); g->intrinsic = FALSE; g->u.proc.n_args = -1; g->u.proc.other_t = NULL; } else if ((ffesymbol_basictype (s) != FFEINFO_basictypeNONE) && (g->type == FFEGLOBAL_typeFUNC) && ((ffesymbol_basictype (s) != g->u.proc.bt) || (ffesymbol_kindtype (s) != g->u.proc.kt) || ((ffesymbol_size (s) != FFETARGET_charactersizeNONE) && (ffesymbol_size (s) != g->u.proc.sz)))) { /* The previous reference and this new function definition disagree about the type of the function. I (Burley) think this rarely occurs, because when this code is reached, the type info doesn't appear to be filled in yet. */ if (ffe_is_globals () || ffe_is_warn_globals ()) { ffebad_start (ffe_is_globals () ? FFEBAD_FILEWIDE_TYPE_MISMATCH : FFEBAD_FILEWIDE_TYPE_MISMATCH_W); ffebad_string (ffelex_token_text (t)); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } g->type = FFEGLOBAL_typeANY; return; } if (g->intrinsic && !g->explicit_intrinsic && ffe_is_warn_globals ()) { /* This name, previously used as an intrinsic, now is known to also be a global procedure name. Warn, since the previous use as an intrinsic might have been intended to refer to this procedure. */ ffebad_start (FFEBAD_INTRINSIC_GLOBAL); ffebad_string (ffelex_token_text (t)); ffebad_string ("global"); ffebad_string ("intrinsic"); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } g->t = ffelex_token_use (t); if ((g->tick == 0) || (g->u.proc.bt == FFEINFO_basictypeNONE) || (g->u.proc.kt == FFEINFO_kindtypeNONE)) { g->u.proc.bt = ffesymbol_basictype (s); g->u.proc.kt = ffesymbol_kindtype (s); g->u.proc.sz = ffesymbol_size (s); } /* If there's a known disagreement about the kind of program unit, then don't even bother tracking arglist argreement. */ if ((g->tick != 0) && (g->type != type)) g->u.proc.n_args = -1; g->tick = ffe_count_2; g->type = type; g->u.proc.defined = TRUE; } ffesymbol_set_global (s, g); #endif } /* ffeglobal_pad_common -- Check initial padding of common area ffesymbol s; // the common area ffetargetAlign pad; // the initial padding ffeglobal_pad_common(s,pad,ffesymbol_where_line(s), ffesymbol_where_column(s)); In global-enabled mode, make sure the padding agrees with any existing padding established for the common area, otherwise complain. In global-disabled mode, warn about nonzero padding. */ void ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl, ffewhereColumn wc) { #if FFEGLOBAL_ENABLED ffeglobal g; g = ffesymbol_global (s); if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON)) return; /* Let someone else catch this! */ if (g->type == FFEGLOBAL_typeANY) return; if (!g->u.common.have_pad) { g->u.common.have_pad = TRUE; g->u.common.pad = pad; g->u.common.pad_where_line = ffewhere_line_use (wl); g->u.common.pad_where_col = ffewhere_column_use (wc); if (pad != 0) { char padding[20]; sprintf (&padding[0], "%" ffetargetAlign_f "u", pad); ffebad_start (FFEBAD_COMMON_INIT_PAD); ffebad_string (ffesymbol_text (s)); ffebad_string (padding); ffebad_string ((pad == 1) ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); ffebad_here (0, wl, wc); ffebad_finish (); } } else { if (g->u.common.pad != pad) { char padding_1[20]; char padding_2[20]; sprintf (&padding_1[0], "%" ffetargetAlign_f "u", pad); sprintf (&padding_2[0], "%" ffetargetAlign_f "u", g->u.common.pad); ffebad_start (FFEBAD_COMMON_DIFF_PAD); ffebad_string (ffesymbol_text (s)); ffebad_string (padding_1); ffebad_here (0, wl, wc); ffebad_string (padding_2); ffebad_string ((pad == 1) ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); ffebad_string ((g->u.common.pad == 1) ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); ffebad_here (1, g->u.common.pad_where_line, g->u.common.pad_where_col); ffebad_finish (); } if (g->u.common.pad < pad) { g->u.common.pad = pad; g->u.common.pad_where_line = ffewhere_line_use (wl); g->u.common.pad_where_col = ffewhere_column_use (wc); } } #endif } /* Collect info for a global's argument. */ void ffeglobal_proc_def_arg (ffesymbol s, int argno, char *name, ffeglobalArgSummary as, ffeinfoBasictype bt, ffeinfoKindtype kt, bool array) { ffeglobal g = ffesymbol_global (s); ffeglobalArgInfo_ ai; assert (g != NULL); if (g->type == FFEGLOBAL_typeANY) return; assert (g->u.proc.n_args >= 0); if (argno >= g->u.proc.n_args) return; /* Already complained about this discrepancy. */ ai = &g->u.proc.arg_info[argno]; /* Maybe warn about previous references. */ if ((ai->t != NULL) && ffe_is_warn_globals ()) { char *refwhy = NULL; char *defwhy = NULL; bool warn = FALSE; switch (as) { case FFEGLOBAL_argsummaryREF: if ((ai->as != FFEGLOBAL_argsummaryREF) && (ai->as != FFEGLOBAL_argsummaryNONE) && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */ || (ai->bt != FFEINFO_basictypeCHARACTER) || (ai->bt == bt))) { warn = TRUE; refwhy = "passed by reference"; } break; case FFEGLOBAL_argsummaryDESCR: if ((ai->as != FFEGLOBAL_argsummaryDESCR) && (ai->as != FFEGLOBAL_argsummaryNONE) && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */ || (bt != FFEINFO_basictypeCHARACTER) || (ai->bt == bt))) { warn = TRUE; refwhy = "passed by descriptor"; } break; case FFEGLOBAL_argsummaryPROC: if ((ai->as != FFEGLOBAL_argsummaryPROC) && (ai->as != FFEGLOBAL_argsummarySUBR) && (ai->as != FFEGLOBAL_argsummaryFUNC) && (ai->as != FFEGLOBAL_argsummaryNONE)) { warn = TRUE; refwhy = "a procedure"; } break; case FFEGLOBAL_argsummarySUBR: if ((ai->as != FFEGLOBAL_argsummaryPROC) && (ai->as != FFEGLOBAL_argsummarySUBR) && (ai->as != FFEGLOBAL_argsummaryNONE)) { warn = TRUE; refwhy = "a subroutine"; } break; case FFEGLOBAL_argsummaryFUNC: if ((ai->as != FFEGLOBAL_argsummaryPROC) && (ai->as != FFEGLOBAL_argsummaryFUNC) && (ai->as != FFEGLOBAL_argsummaryNONE)) { warn = TRUE; refwhy = "a function"; } break; case FFEGLOBAL_argsummaryALTRTN: if ((ai->as != FFEGLOBAL_argsummaryALTRTN) && (ai->as != FFEGLOBAL_argsummaryNONE)) { warn = TRUE; refwhy = "an alternate-return label"; } break; default: break; } if ((refwhy != NULL) && (defwhy == NULL)) { /* Fill in the def info. */ switch (ai->as) { case FFEGLOBAL_argsummaryNONE: defwhy = "omitted"; break; case FFEGLOBAL_argsummaryVAL: defwhy = "passed by value"; break; case FFEGLOBAL_argsummaryREF: defwhy = "passed by reference"; break; case FFEGLOBAL_argsummaryDESCR: defwhy = "passed by descriptor"; break; case FFEGLOBAL_argsummaryPROC: defwhy = "a procedure"; break; case FFEGLOBAL_argsummarySUBR: defwhy = "a subroutine"; break; case FFEGLOBAL_argsummaryFUNC: defwhy = "a function"; break; case FFEGLOBAL_argsummaryALTRTN: defwhy = "an alternate-return label"; break; #if 0 case FFEGLOBAL_argsummaryPTR: defwhy = "a pointer"; break; #endif default: defwhy = "???"; break; } } if (!warn && (bt != FFEINFO_basictypeHOLLERITH) && (bt != FFEINFO_basictypeTYPELESS) && (bt != FFEINFO_basictypeNONE) && (ai->bt != FFEINFO_basictypeHOLLERITH) && (ai->bt != FFEINFO_basictypeTYPELESS) && (ai->bt != FFEINFO_basictypeNONE)) { /* Check types. */ if ((bt != ai->bt) && ((bt != FFEINFO_basictypeREAL) || (ai->bt != FFEINFO_basictypeCOMPLEX)) && ((bt != FFEINFO_basictypeCOMPLEX) || (ai->bt != FFEINFO_basictypeREAL))) { warn = TRUE; /* We can cope with these differences. */ refwhy = "one type"; defwhy = "some other type"; } if (!warn && (kt != ai->kt)) { warn = TRUE; refwhy = "one precision"; defwhy = "some other precision"; } } if (warn) { char num[60]; if (name == NULL) sprintf (&num[0], "%d", argno + 1); else { if (strlen (name) < 30) sprintf (&num[0], "%d (named `%s')", argno + 1, name); else sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, name); } ffebad_start (FFEBAD_FILEWIDE_ARG_W); ffebad_string (ffesymbol_text (s)); ffebad_string (num); ffebad_string (refwhy); ffebad_string (defwhy); ffebad_here (0, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t)); ffebad_finish (); } } /* Define this argument. */ if (ai->t != NULL) ffelex_token_kill (ai->t); if ((as != FFEGLOBAL_argsummaryPROC) || (ai->t == NULL)) ai->as = as; /* Otherwise leave SUBR/FUNC info intact. */ ai->t = ffelex_token_use (g->t); if (name == NULL) ai->name = NULL; else { ai->name = malloc_new_ks (malloc_pool_image (), "ffeglobalArgInfo_ name", strlen (name) + 1); strcpy (ai->name, name); } ai->bt = bt; ai->kt = kt; ai->array = array; } /* Collect info on #args a global accepts. */ void ffeglobal_proc_def_nargs (ffesymbol s, int n_args) { ffeglobal g = ffesymbol_global (s); assert (g != NULL); if (g->type == FFEGLOBAL_typeANY) return; if (g->u.proc.n_args >= 0) { if (g->u.proc.n_args == n_args) return; if (ffe_is_warn_globals ()) { ffebad_start (FFEBAD_FILEWIDE_NARGS_W); ffebad_string (ffesymbol_text (s)); if (g->u.proc.n_args > n_args) ffebad_string ("few"); else ffebad_string ("many"); ffebad_here (0, ffelex_token_where_line (g->u.proc.other_t), ffelex_token_where_column (g->u.proc.other_t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } } /* This is new info we can use in cross-checking future references and a possible future definition. */ g->u.proc.n_args = n_args; g->u.proc.other_t = NULL; /* No other reference yet. */ if (n_args == 0) { g->u.proc.arg_info = NULL; return; } g->u.proc.arg_info = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (), "ffeglobalArgInfo_", n_args * sizeof (g->u.proc.arg_info[0])); while (n_args-- > 0) g->u.proc.arg_info[n_args].t = NULL; } /* Verify that the info for a global's argument is valid. */ bool ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as, ffeinfoBasictype bt, ffeinfoKindtype kt, bool array, ffelexToken t) { ffeglobal g = ffesymbol_global (s); ffeglobalArgInfo_ ai; assert (g != NULL); if (g->type == FFEGLOBAL_typeANY) return FALSE; assert (g->u.proc.n_args >= 0); if (argno >= g->u.proc.n_args) return TRUE; /* Already complained about this discrepancy. */ ai = &g->u.proc.arg_info[argno]; /* Warn about previous references. */ if (ai->t != NULL) { char *refwhy = NULL; char *defwhy = NULL; bool fail = FALSE; bool warn = FALSE; switch (as) { case FFEGLOBAL_argsummaryNONE: if (g->u.proc.defined) { fail = TRUE; refwhy = "omitted"; defwhy = "not optional"; } break; case FFEGLOBAL_argsummaryVAL: if (ai->as != FFEGLOBAL_argsummaryVAL) { fail = TRUE; refwhy = "passed by value"; } break; case FFEGLOBAL_argsummaryREF: if ((ai->as != FFEGLOBAL_argsummaryREF) && (ai->as != FFEGLOBAL_argsummaryNONE) && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */ || (ai->bt != FFEINFO_basictypeCHARACTER) || (ai->bt == bt))) { fail = TRUE; refwhy = "passed by reference"; } break; case FFEGLOBAL_argsummaryDESCR: if ((ai->as != FFEGLOBAL_argsummaryDESCR) && (ai->as != FFEGLOBAL_argsummaryNONE) && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */ || (bt != FFEINFO_basictypeCHARACTER) || (ai->bt == bt))) { fail = TRUE; refwhy = "passed by descriptor"; } break; case FFEGLOBAL_argsummaryPROC: if ((ai->as != FFEGLOBAL_argsummaryPROC) && (ai->as != FFEGLOBAL_argsummarySUBR) && (ai->as != FFEGLOBAL_argsummaryFUNC) && (ai->as != FFEGLOBAL_argsummaryNONE)) { fail = TRUE; refwhy = "a procedure"; } break; case FFEGLOBAL_argsummarySUBR: if ((ai->as != FFEGLOBAL_argsummaryPROC) && (ai->as != FFEGLOBAL_argsummarySUBR) && (ai->as != FFEGLOBAL_argsummaryNONE)) { fail = TRUE; refwhy = "a subroutine"; } break; case FFEGLOBAL_argsummaryFUNC: if ((ai->as != FFEGLOBAL_argsummaryPROC) && (ai->as != FFEGLOBAL_argsummaryFUNC) && (ai->as != FFEGLOBAL_argsummaryNONE)) { fail = TRUE; refwhy = "a function"; } break; case FFEGLOBAL_argsummaryALTRTN: if ((ai->as != FFEGLOBAL_argsummaryALTRTN) && (ai->as != FFEGLOBAL_argsummaryNONE)) { fail = TRUE; refwhy = "an alternate-return label"; } break; #if 0 case FFEGLOBAL_argsummaryPTR: if ((ai->as != FFEGLOBAL_argsummaryPTR) && (ai->as != FFEGLOBAL_argsummaryNONE)) { fail = TRUE; refwhy = "a pointer"; } break; #endif default: break; } if ((refwhy != NULL) && (defwhy == NULL)) { /* Fill in the def info. */ switch (ai->as) { case FFEGLOBAL_argsummaryNONE: defwhy = "omitted"; break; case FFEGLOBAL_argsummaryVAL: defwhy = "passed by value"; break; case FFEGLOBAL_argsummaryREF: defwhy = "passed by reference"; break; case FFEGLOBAL_argsummaryDESCR: defwhy = "passed by descriptor"; break; case FFEGLOBAL_argsummaryPROC: defwhy = "a procedure"; break; case FFEGLOBAL_argsummarySUBR: defwhy = "a subroutine"; break; case FFEGLOBAL_argsummaryFUNC: defwhy = "a function"; break; case FFEGLOBAL_argsummaryALTRTN: defwhy = "an alternate-return label"; break; #if 0 case FFEGLOBAL_argsummaryPTR: defwhy = "a pointer"; break; #endif default: defwhy = "???"; break; } } if (!fail && !warn && (bt != FFEINFO_basictypeHOLLERITH) && (bt != FFEINFO_basictypeTYPELESS) && (bt != FFEINFO_basictypeNONE) && (ai->bt != FFEINFO_basictypeHOLLERITH) && (ai->bt != FFEINFO_basictypeNONE) && (ai->bt != FFEINFO_basictypeTYPELESS)) { /* Check types. */ if ((bt != ai->bt) && ((bt != FFEINFO_basictypeREAL) || (ai->bt != FFEINFO_basictypeCOMPLEX)) && ((bt != FFEINFO_basictypeCOMPLEX) || (ai->bt != FFEINFO_basictypeREAL))) { if (((bt == FFEINFO_basictypeINTEGER) && (ai->bt == FFEINFO_basictypeLOGICAL)) || ((bt == FFEINFO_basictypeLOGICAL) && (ai->bt == FFEINFO_basictypeINTEGER))) warn = TRUE; /* We can cope with these differences. */ else fail = TRUE; refwhy = "one type"; defwhy = "some other type"; } if (!fail && !warn && (kt != ai->kt)) { fail = TRUE; refwhy = "one precision"; defwhy = "some other precision"; } } if (fail && ! g->u.proc.defined) { /* No point failing if we're worried only about invocations. */ fail = FALSE; warn = TRUE; } if (fail && ! ffe_is_globals ()) { warn = TRUE; fail = FALSE; } if (fail || (warn && ffe_is_warn_globals ())) { char num[60]; if (ai->name == NULL) sprintf (&num[0], "%d", argno + 1); else { if (strlen (ai->name) < 30) sprintf (&num[0], "%d (named `%s')", argno + 1, ai->name); else sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, ai->name); } ffebad_start (fail ? FFEBAD_FILEWIDE_ARG : FFEBAD_FILEWIDE_ARG_W); ffebad_string (ffesymbol_text (s)); ffebad_string (num); ffebad_string (refwhy); ffebad_string (defwhy); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t)); ffebad_finish (); return (fail ? FALSE : TRUE); } if (warn) return TRUE; } /* Define this argument. */ if (ai->t != NULL) ffelex_token_kill (ai->t); if ((as != FFEGLOBAL_argsummaryPROC) || (ai->t == NULL)) ai->as = as; ai->t = ffelex_token_use (g->t); ai->name = NULL; ai->bt = bt; ai->kt = kt; ai->array = array; return TRUE; } bool ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t) { ffeglobal g = ffesymbol_global (s); assert (g != NULL); if (g->type == FFEGLOBAL_typeANY) return FALSE; if (g->u.proc.n_args >= 0) { if (g->u.proc.n_args == n_args) return TRUE; if (g->u.proc.defined && ffe_is_globals ()) { ffebad_start (FFEBAD_FILEWIDE_NARGS); ffebad_string (ffesymbol_text (s)); if (g->u.proc.n_args > n_args) ffebad_string ("few"); else ffebad_string ("many"); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); return FALSE; } if (ffe_is_warn_globals ()) { ffebad_start (FFEBAD_FILEWIDE_NARGS_W); ffebad_string (ffesymbol_text (s)); if (g->u.proc.n_args > n_args) ffebad_string ("few"); else ffebad_string ("many"); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } return TRUE; /* Don't replace the info we already have. */ } /* This is new info we can use in cross-checking future references and a possible future definition. */ g->u.proc.n_args = n_args; g->u.proc.other_t = ffelex_token_use (t); /* Make this "the" place we found the global, since it has the most info. */ if (g->t != NULL) ffelex_token_kill (g->t); g->t = ffelex_token_use (t); if (n_args == 0) { g->u.proc.arg_info = NULL; return TRUE; } g->u.proc.arg_info = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (), "ffeglobalArgInfo_", n_args * sizeof (g->u.proc.arg_info[0])); while (n_args-- > 0) g->u.proc.arg_info[n_args].t = NULL; return TRUE; } /* Return a global for a promoted symbol (one that has heretofore been assumed to be local, but since discovered to be global). */ ffeglobal ffeglobal_promoted (ffesymbol s) { #if FFEGLOBAL_ENABLED ffename n; ffeglobal g; assert (ffesymbol_global (s) == NULL); n = ffename_find (ffeglobal_filewide_, ffename_token (ffesymbol_name (s))); g = ffename_global (n); return g; #else return NULL; #endif } /* Register a reference to an intrinsic. Such a reference is always valid, though a warning might be in order if the same name has already been used for a global. */ void ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit) { #if FFEGLOBAL_ENABLED ffename n; ffeglobal g; if (ffesymbol_global (s) == NULL) { n = ffename_find (ffeglobal_filewide_, t); g = ffename_global (n); } else { g = ffesymbol_global (s); n = NULL; } if ((g != NULL) && (g->type == FFEGLOBAL_typeANY)) return; if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE)) { if (! explicit && ! g->intrinsic && ffe_is_warn_globals ()) { /* This name, previously used as a global, now is used for an intrinsic. Warn, since this new use as an intrinsic might have been intended to refer to the global procedure. */ ffebad_start (FFEBAD_INTRINSIC_GLOBAL); ffebad_string (ffelex_token_text (t)); ffebad_string ("intrinsic"); ffebad_string ("global"); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } } else { if (g == NULL) { g = ffeglobal_new_ (n); g->tick = ffe_count_2; g->type = FFEGLOBAL_typeNONE; g->intrinsic = TRUE; g->explicit_intrinsic = explicit; g->t = ffelex_token_use (t); } else if (g->intrinsic && (explicit != g->explicit_intrinsic) && (g->tick != ffe_count_2) && ffe_is_warn_globals ()) { /* An earlier reference to this intrinsic disagrees with this reference vis-a-vis explicit `intrinsic foo', which suggests that the one relying on implicit intrinsicacity might have actually intended to refer to a global of the same name. */ ffebad_start (FFEBAD_INTRINSIC_EXPIMP); ffebad_string (ffelex_token_text (t)); ffebad_string (explicit ? "explicit" : "implicit"); ffebad_string (explicit ? "implicit" : "explicit"); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } } g->intrinsic = TRUE; if (explicit) g->explicit_intrinsic = TRUE; ffesymbol_set_global (s, g); #endif } /* Register a reference to a global. Returns TRUE if the reference is valid. */ bool ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type) { #if FFEGLOBAL_ENABLED ffename n = NULL; ffeglobal g; /* It is never really _known_ that an EXTERNAL statement names a BLOCK DATA by just looking at the program unit, so override a different notion here. */ if (type == FFEGLOBAL_typeBDATA) type = FFEGLOBAL_typeEXT; g = ffesymbol_global (s); if (g == NULL) { n = ffename_find (ffeglobal_filewide_, t); g = ffename_global (n); if (g != NULL) ffesymbol_set_global (s, g); } if ((g != NULL) && (g->type == FFEGLOBAL_typeANY)) return TRUE; if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE) && (g->type != FFEGLOBAL_typeEXT) && (g->type != type) && (type != FFEGLOBAL_typeEXT)) { /* Disagreement about (fully refined) class of program unit (main, subroutine, function, block data). Treat EXTERNAL/ COMMON disagreements distinctly. */ if ((((type == FFEGLOBAL_typeBDATA) && (g->type != FFEGLOBAL_typeCOMMON)) || ((g->type == FFEGLOBAL_typeBDATA) && (type != FFEGLOBAL_typeCOMMON) && ! g->u.proc.defined))) { #if 0 /* This is likely to just annoy people. */ if (ffe_is_warn_globals ()) { /* Warn about EXTERNAL of a COMMON name, though it works. */ ffebad_start (FFEBAD_FILEWIDE_TIFF); ffebad_string (ffelex_token_text (t)); ffebad_string (ffeglobal_type_string_[type]); ffebad_string (ffeglobal_type_string_[g->type]); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } #endif } else if (ffe_is_globals () || ffe_is_warn_globals ()) { ffebad_start (ffe_is_globals () ? FFEBAD_FILEWIDE_DISAGREEMENT : FFEBAD_FILEWIDE_DISAGREEMENT_W); ffebad_string (ffelex_token_text (t)); ffebad_string (ffeglobal_type_string_[type]); ffebad_string (ffeglobal_type_string_[g->type]); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); g->type = FFEGLOBAL_typeANY; return (! ffe_is_globals ()); } } if ((g != NULL) && (type == FFEGLOBAL_typeFUNC)) { /* If just filling in this function's type, do so. */ if ((g->tick == ffe_count_2) && (ffesymbol_basictype (s) != FFEINFO_basictypeNONE) && (ffesymbol_kindtype (s) != FFEINFO_kindtypeNONE)) { g->u.proc.bt = ffesymbol_basictype (s); g->u.proc.kt = ffesymbol_kindtype (s); g->u.proc.sz = ffesymbol_size (s); } /* Make sure there is type agreement. */ if (g->type == FFEGLOBAL_typeFUNC && g->u.proc.bt != FFEINFO_basictypeNONE && ffesymbol_basictype (s) != FFEINFO_basictypeNONE && (ffesymbol_basictype (s) != g->u.proc.bt || ffesymbol_kindtype (s) != g->u.proc.kt /* CHARACTER*n disagreements matter only once a definition is involved, since the definition might be CHARACTER*(*), which accepts all references. */ || (g->u.proc.defined && ffesymbol_size (s) != g->u.proc.sz && ffesymbol_size (s) != FFETARGET_charactersizeNONE && g->u.proc.sz != FFETARGET_charactersizeNONE))) { int error; /* Type mismatch between function reference/definition and this subsequent reference (which might just be the filling-in of type info for the definition, but we can't reach here if that's the case and there was a previous definition). It's an error given a previous definition, since that implies inlining can crash the compiler, unless the user asked for no such inlining. */ error = (g->tick != ffe_count_2 && g->u.proc.defined && ffe_is_globals ()); if (error || ffe_is_warn_globals ()) { ffebad_start (error ? FFEBAD_FILEWIDE_TYPE_MISMATCH : FFEBAD_FILEWIDE_TYPE_MISMATCH_W); ffebad_string (ffelex_token_text (t)); if (g->tick == ffe_count_2) { /* Current reference fills in type info for definition. The current token doesn't necessarily point to the actual definition of the function, so use the definition pointer and the pointer to the pre-definition type info. */ ffebad_here (0, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_here (1, ffelex_token_where_line (g->u.proc.other_t), ffelex_token_where_column (g->u.proc.other_t)); } else { /* Current reference is not a filling-in of a current definition. The current token is fine, as is the previous-mention token. */ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); } ffebad_finish (); if (error) g->type = FFEGLOBAL_typeANY; return FALSE; } } } if (g == NULL) { g = ffeglobal_new_ (n); g->t = ffelex_token_use (t); g->tick = ffe_count_2; g->intrinsic = FALSE; g->type = type; g->u.proc.defined = FALSE; g->u.proc.bt = ffesymbol_basictype (s); g->u.proc.kt = ffesymbol_kindtype (s); g->u.proc.sz = ffesymbol_size (s); g->u.proc.n_args = -1; ffesymbol_set_global (s, g); } else if (g->intrinsic && !g->explicit_intrinsic && (g->tick != ffe_count_2) && ffe_is_warn_globals ()) { /* Now known as a global, this name previously was seen as an intrinsic. Warn, in case the previous reference was intended for the same global. */ ffebad_start (FFEBAD_INTRINSIC_GLOBAL); ffebad_string (ffelex_token_text (t)); ffebad_string ("global"); ffebad_string ("intrinsic"); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_finish (); } if ((g->type != type) && (type != FFEGLOBAL_typeEXT)) { /* We've learned more, so point to where we learned it. */ g->t = ffelex_token_use (t); g->type = type; #ifdef FFECOM_globalHOOK g->hook = FFECOM_globalNULL; /* Discard previous _DECL. */ #endif g->u.proc.n_args = -1; } return TRUE; #endif } /* ffeglobal_save_common -- Check SAVE status of common area ffesymbol s; // the common area bool save; // TRUE if SAVEd, FALSE otherwise ffeglobal_save_common(s,save,ffesymbol_where_line(s), ffesymbol_where_column(s)); In global-enabled mode, make sure the save info agrees with any existing info established for the common area, otherwise complain. In global-disabled mode, do nothing. */ void ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl, ffewhereColumn wc) { #if FFEGLOBAL_ENABLED ffeglobal g; g = ffesymbol_global (s); if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON)) return; /* Let someone else catch this! */ if (g->type == FFEGLOBAL_typeANY) return; if (!g->u.common.have_save) { g->u.common.have_save = TRUE; g->u.common.save = save; g->u.common.save_where_line = ffewhere_line_use (wl); g->u.common.save_where_col = ffewhere_column_use (wc); } else { if ((g->u.common.save != save) && ffe_is_pedantic ()) { ffebad_start (FFEBAD_COMMON_DIFF_SAVE); ffebad_string (ffesymbol_text (s)); ffebad_here (save ? 0 : 1, wl, wc); ffebad_here (save ? 1 : 0, g->u.common.pad_where_line, g->u.common.pad_where_col); ffebad_finish (); } } #endif } /* ffeglobal_size_common -- Establish size of COMMON area ffesymbol s; // the common area ffetargetOffset size; // size in units if (ffeglobal_size_common(s,size)) // new size is largest seen In global-enabled mode, set the size if it current size isn't known or is smaller than new size, and for non-blank common, complain if old size is different from new. Return TRUE if the new size is the largest seen for this COMMON area (or if no size was known for it previously). In global-disabled mode, do nothing. */ #if FFEGLOBAL_ENABLED bool ffeglobal_size_common (ffesymbol s, ffetargetOffset size) { ffeglobal g; g = ffesymbol_global (s); if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON)) return FALSE; if (g->type == FFEGLOBAL_typeANY) return FALSE; if (!g->u.common.have_size) { g->u.common.have_size = TRUE; g->u.common.size = size; return TRUE; } if ((g->tick > 0) && (g->tick < ffe_count_2) && (g->u.common.size < size)) { char oldsize[40]; char newsize[40]; /* Common block initialized in a previous program unit, which effectively freezes its size, but now the program is trying to enlarge it. */ sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size); sprintf (&newsize[0], "%" ffetargetOffset_f "d", size); ffebad_start (FFEBAD_COMMON_ENLARGED); ffebad_string (ffesymbol_text (s)); ffebad_string (oldsize); ffebad_string (newsize); ffebad_string ((g->u.common.size == 1) ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); ffebad_string ((size == 1) ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); ffebad_here (0, ffelex_token_where_line (g->u.common.initt), ffelex_token_where_column (g->u.common.initt)); ffebad_here (1, ffesymbol_where_line (s), ffesymbol_where_column (s)); ffebad_finish (); } else if ((g->u.common.size != size) && !g->u.common.blank) { char oldsize[40]; char newsize[40]; /* Warn about this even if not -pedantic, because putting all program units in a single source file is the only way to detect this. Apparently UNIX-model linkers neither handle nor report when they make a common unit smaller than requested, such as when the smaller-declared version is initialized and the larger-declared version is not. So if people complain about strange overwriting, we can tell them to put all their code in a single file and compile that way. Warnings about differing sizes must therefore always be issued. */ sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size); sprintf (&newsize[0], "%" ffetargetOffset_f "d", size); ffebad_start (FFEBAD_COMMON_DIFF_SIZE); ffebad_string (ffesymbol_text (s)); ffebad_string (oldsize); ffebad_string (newsize); ffebad_string ((g->u.common.size == 1) ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); ffebad_string ((size == 1) ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); ffebad_here (0, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); ffebad_here (1, ffesymbol_where_line (s), ffesymbol_where_column (s)); ffebad_finish (); } if (size > g->u.common.size) { g->u.common.size = size; return TRUE; } return FALSE; } #endif void ffeglobal_terminate_1 () { }