improve global/filewide semantic checking

From-SVN: r25319

gcc/f/ChangeLog

+1999-02-19  Craig Burley  <craig@jcb-sc.com>
+
+	* global.c (ffeglobal_ref_progunit_): Warn about a function
+	definition that disagrees with the type of a previous reference.
+	Improve commentary.  Fix a couple of minor bugs.  Clean up
+	some code.
+	* news.texi: Spread the joy.
+
 1999-02-18  Craig Burley  <craig@jcb-sc.com>
 
 	* expr.c (ffeexpr_finished_): Disallow non-default INTEGER

gcc/f/global.c

@@ -181,6 +181,7 @@ ffeglobal_init_common (ffesymbol s, ffelexToken t)
     {
       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 ();
@@ -229,10 +230,13 @@ ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank)
     {
       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 ()
@@ -258,6 +262,10 @@ ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank)
 	       && !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");
@@ -308,6 +316,7 @@ ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 	  || (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 ()
@@ -327,6 +336,13 @@ ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 	   && (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 ()
@@ -353,11 +369,16 @@ ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 	  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 ()
@@ -377,6 +398,10 @@ ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 	  && !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");
@@ -395,10 +420,12 @@ ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 	  g->u.proc.kt = ffesymbol_kindtype (s);
 	  g->u.proc.sz = ffesymbol_size (s);
 	}
-      g->tick = ffe_count_2;
+      /* 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;
     }
@@ -1160,6 +1187,10 @@ ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool 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");
@@ -1186,6 +1217,11 @@ ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit)
 	       && (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");
@@ -1235,10 +1271,13 @@ ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 
   if ((g != NULL)
       && (g->type != FFEGLOBAL_typeNONE)
-      && (g->type != type)
       && (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)
@@ -1248,6 +1287,7 @@ ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 #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]);
@@ -1260,23 +1300,11 @@ ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 	    }
 #endif
 	}
-      else if (ffe_is_globals ())
-	{
-	  ffebad_start (FFEBAD_FILEWIDE_DISAGREEMENT);
-	  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 FALSE;
-	}
-      else if (ffe_is_warn_globals ())
+      else if (ffe_is_globals () || ffe_is_warn_globals ())
 	{
-	  ffebad_start (FFEBAD_FILEWIDE_DISAGREEMENT_W);
+	  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]);
@@ -1286,7 +1314,7 @@ ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 		       ffelex_token_where_column (g->t));
 	  ffebad_finish ();
 	  g->type = FFEGLOBAL_typeANY;
-	  return TRUE;
+	  return (! ffe_is_globals ());
 	}
     }
 
@@ -1302,39 +1330,65 @@ ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 	  g->u.proc.kt = ffesymbol_kindtype (s);
 	  g->u.proc.sz = ffesymbol_size (s);
 	}
-      /* Else, make sure there is type agreement.  */
-      else if ((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)
-		   || ((ffesymbol_size (s) != g->u.proc.sz)
+      /* 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
-		       && (g->u.proc.sz != FFETARGET_charactersizeNONE))))
-	{
-	  if (ffe_is_globals ())
+		   && ffe_is_globals ());
+	  if (error || ffe_is_warn_globals ())
 	    {
-	      ffebad_start (FFEBAD_FILEWIDE_TYPE_MISMATCH);
+	      ffebad_start (error
+			    ? 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),
+	      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_finish ();
-	      g->type = FFEGLOBAL_typeANY;
-	      return FALSE;
+		  ffebad_here (1, ffelex_token_where_line (g->u.proc.other_t),
+			       ffelex_token_where_column (g->u.proc.other_t));
 		}
-	  if (ffe_is_warn_globals ())
+	      else
 		{
-	      ffebad_start (FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
-	      ffebad_string (ffelex_token_text (t));
+		  /* 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 ();
 		}
+	      ffebad_finish ();
+	      if (error)
 		g->type = FFEGLOBAL_typeANY;
-	  return TRUE;
+	      return FALSE;
+	    }
 	}
     }
 
@@ -1357,6 +1411,9 @@ ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 	   && (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");

gcc/f/news.texi

@@ -73,6 +73,11 @@ now are recognized by @code{g77}
 as if they ended in @samp{.for} and @samp{.fpp}, respectively.
 
 @item
+@code{g77} now warns about a reference to a function
+when the corresponding @emph{subsequent} function program unit
+disagrees with the reference concerning the type of the function.
+
+@item
 Improve documentation and indexing,
 including information on Year 2000 (Y2K) compliance.
 @end itemize

gcc/f/version.c

-char *ffe_version_string = "0.5.24-19990218";
+char *ffe_version_string = "0.5.24-19990219";