This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[patch, fortran] Fix PR 91443


Hello world,

this patch fixes PR 91443, in which we did not warn about a mismatched
external procedure. The problem was that the module this was called in
was resolved before parsing of the procedure ever started.

The approach taken here is to move the checking of external procedures
to a stage after normal resolution.  And, of course, fix the resulting
fallout from regression-testing :-)

There is also one policy change in the patch. Previously, we only warned
about mismatched declarations.  Now, this is a hard error unless the
user specifies -std=legacy.  The reason is that we have not yet solved
our single declaration problem, but it cannot be solved unless all
of a procedure's callers match.  People who have such broken code
should at least be made aware that they have a problem. However, I would
like to have some sort of agreement on this point before the patch
is committed.  This can also be changed (see the code at the bottom
of frontend-passes.c).

Once this is in, the next step is to issue errors for mismatching
calls where the callee is not in the same file.  This can be done
with the infrastructure of this patch.

So, OK for trunk?

Regards

	Thomas

2019-08-15  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91443
	* frontend-passes.c (check_externals_expr): New function.
	(check_externals_code): New function.
	(gfc_check_externals): New function.
	* gfortran.h (debug): Add prototypes for gfc_symbol * and
	gfc_expr *.
	(gfc_check_externals): Add prototype.
	* interface.c (compare_actual_formal): Do not complain about
	alternate returns if the formal argument is optional.
	(gfc_procedure_use): Handle cases when an error has been issued
	previously.  Break long line.
	* parse.c (gfc_parse_file): Call gfc_check_externals for all
	external procedures.
	* resolve.c (resolve_global_procedure): Remove checking of
	argument list.

2019-08-15  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91443
	* gfortran.dg/argument_checking_19.f90: New test.
	* gfortran.dg/altreturn_10.f90: Change dg-warning to dg-error.
	* gfortran.dg/dec_union_11.f90: Add -std=legacy.
	* gfortran.dg/hollerith8.f90: Likewise. Remove warning for
	Hollerith constant.
	* gfortran.dg/integer_exponentiation_2.f90: New subroutine gee_i8;
	use it to avoid type mismatches.
	* gfortran.dg/pr41011.f: Add -std=legacy.
	* gfortran.dg/whole_file_1.f90: Change warnings to errors.
	* gfortran.dg/whole_file_2.f90: Likewise.

Index: fortran/frontend-passes.c
===================================================================
--- fortran/frontend-passes.c	(Revision 274394)
+++ fortran/frontend-passes.c	(Arbeitskopie)
@@ -56,7 +56,6 @@ static gfc_expr* check_conjg_transpose_variable (g
 static int call_external_blas (gfc_code **, int *, void *);
 static int matmul_temp_args (gfc_code **, int *,void *data);
 static int index_interchange (gfc_code **, int*, void *);
-
 static bool is_fe_temp (gfc_expr *e);
 
 #ifdef CHECKING_P
@@ -5364,3 +5363,100 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code
     }
   return 0;
 }
+
+/* As a post-resolution step, check that all global symbols which are
+   not declared in the source file match in their call signatures.
+   We do this by looping over the code (and expressions). The first call
+   we happen to find is assumed to be canonical.  */
+
+/* Callback for external functions.  */
+
+static int
+check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
+		      void *data ATTRIBUTE_UNUSED)
+{
+  gfc_expr *e = *ep;
+  gfc_symbol *sym, *def_sym;
+  gfc_gsymbol *gsym;
+
+  if (e->expr_type != EXPR_FUNCTION)
+    return 0;
+
+  sym = e->value.function.esym;
+
+  if (sym == NULL || sym->attr.is_bind_c)
+    return 0;
+
+  if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
+    return 0;
+
+  gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
+  if (gsym == NULL)
+    return 0;
+
+  gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+
+  if (sym && def_sym)
+    gfc_procedure_use (def_sym, &e->value.function.actual, &e->where);
+
+  return 0;
+}
+
+/* Callback for external code.  */
+
+static int
+check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+		      void *data ATTRIBUTE_UNUSED)
+{
+  gfc_code *co = *c;
+  gfc_symbol *sym, *def_sym;
+  gfc_gsymbol *gsym;
+
+  if (co->op != EXEC_CALL)
+    return 0;
+
+  sym = co->resolved_sym;
+  if (sym == NULL || sym->attr.is_bind_c)
+    return 0;
+
+  if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
+    return 0;
+
+  if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
+    return 0;
+
+  gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
+  if (gsym == NULL)
+    return 0;
+
+  gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+
+  if (sym && def_sym)
+    gfc_procedure_use (def_sym, &co->ext.actual, &co->loc);
+
+  return 0;
+}
+
+/* Called routine.  */
+
+void
+gfc_check_externals (gfc_namespace *ns)
+{
+
+  gfc_clear_error ();
+
+  /* Turn errors into warnings if -std=legacy is given by the user.  */
+
+  if (!pedantic && !(gfc_option.warn_std & GFC_STD_LEGACY))
+    gfc_errors_to_warnings (true);
+
+  gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
+
+  for (ns = ns->contained; ns; ns = ns->sibling)
+    {
+      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+	gfc_check_externals (ns);
+    }
+
+  gfc_errors_to_warnings (false);
+}
Index: fortran/gfortran.h
===================================================================
--- fortran/gfortran.h	(Revision 274370)
+++ fortran/gfortran.h	(Arbeitskopie)
@@ -3477,6 +3477,8 @@ void gfc_dump_parse_tree (gfc_namespace *, FILE *)
 void gfc_dump_c_prototypes (gfc_namespace *, FILE *);
 void gfc_dump_external_c_prototypes (FILE *);
 void gfc_dump_global_symbols (FILE *);
+void debug (gfc_symbol *);
+void debug (gfc_expr *);
 
 /* parse.c */
 bool gfc_parse_file (void);
@@ -3551,6 +3553,7 @@ int gfc_dummy_code_callback (gfc_code **, int *, v
 int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *);
 int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *);
 bool gfc_has_dimen_vector_ref (gfc_expr *e);
+void gfc_check_externals (gfc_namespace *);
 
 /* simplify.c */
 
Index: fortran/interface.c
===================================================================
--- fortran/interface.c	(Revision 274370)
+++ fortran/interface.c	(Arbeitskopie)
@@ -2979,10 +2979,15 @@ compare_actual_formal (gfc_actual_arglist **ap, gf
 
       if (a->expr == NULL)
 	{
-	  if (where)
-	    gfc_error_now ("Unexpected alternate return specifier in "
-			   "subroutine call at %L", where);
-	  return false;
+	  if (f->sym->attr.optional)
+	    continue;
+	  else
+	    {
+	      if (where)
+		gfc_error_now ("Unexpected alternate return specifier in "
+			       "subroutine call at %L", where);
+	      return false;
+	    }
 	}
 
       /* Make sure that intrinsic vtables exist for calls to unlimited
@@ -3723,6 +3728,9 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
 
       for (a = *ap; a; a = a->next)
 	{
+	  if (a->expr && a->expr->error)
+	    return false;
+
 	  /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
 	  if (a->name != NULL && a->name[0] != '%')
 	    {
@@ -3738,6 +3746,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
 	      gfc_error ("Assumed-type argument %s at %L requires an explicit "
 			 "interface", a->expr->symtree->n.sym->name,
 			 &a->expr->where);
+	      a->expr->error = 1;
 	      break;
 	    }
 
@@ -3751,6 +3760,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
 	      gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
 			 "component at %L requires an explicit interface for "
 			 "procedure %qs", &a->expr->where, sym->name);
+	      a->expr->error = 1;
 	      break;
 	    }
 
@@ -3764,6 +3774,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
 	      gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
 			 "component at %L requires an explicit interface for "
 			 "procedure %qs", &a->expr->where, sym->name);
+	      a->expr->error = 1;
 	      break;
 	    }
 
@@ -3770,7 +3781,9 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
 	  if (a->expr && a->expr->expr_type == EXPR_NULL
 	      && a->expr->ts.type == BT_UNKNOWN)
 	    {
-	      gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
+	      gfc_error ("MOLD argument to NULL required at %L",
+			 &a->expr->where);
+	      a->expr->error = 1;
 	      return false;
 	    }
 
@@ -3780,6 +3793,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
 	    {
 	      gfc_error ("Assumed-rank argument requires an explicit interface "
 			 "at %L", &a->expr->where);
+	      a->expr->error = 1;
 	      return false;
 	    }
 	}
Index: fortran/parse.c
===================================================================
--- fortran/parse.c	(Revision 274370)
+++ fortran/parse.c	(Arbeitskopie)
@@ -6319,6 +6319,12 @@ done:
   /* Do the resolution.  */
   resolve_all_program_units (gfc_global_ns_list);
 
+
+  /* Fixup for external procedures.  */
+  for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
+       gfc_current_ns = gfc_current_ns->sibling)
+    gfc_check_externals (gfc_current_ns);
+
   /* Do the parse tree dump.  */
   gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
 
Index: fortran/resolve.c
===================================================================
--- fortran/resolve.c	(Revision 274370)
+++ fortran/resolve.c	(Arbeitskopie)
@@ -2506,8 +2506,7 @@ gfc_explicit_interface_required (gfc_symbol *sym,
 
 
 static void
-resolve_global_procedure (gfc_symbol *sym, locus *where,
-			  gfc_actual_arglist **actual, int sub)
+resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
 {
   gfc_gsymbol * gsym;
   gfc_namespace *ns;
@@ -2615,14 +2614,6 @@ static void
 			 " %s", sym->name, &sym->declared_at, reason);
 	  goto done;
 	}
-
-      if (!pedantic
-	  || ((gfc_option.warn_std & GFC_STD_LEGACY)
-	      && !(gfc_option.warn_std & GFC_STD_GNU)))
-	gfc_errors_to_warnings (true);
-
-      if (sym->attr.if_source != IFSRC_IFBODY)
-	gfc_procedure_use (def_sym, actual, where);
     }
 
 done:
@@ -3198,8 +3189,7 @@ resolve_function (gfc_expr *expr)
 
   /* If the procedure is external, check for usage.  */
   if (sym && is_external_proc (sym))
-    resolve_global_procedure (sym, &expr->where,
-			      &expr->value.function.actual, 0);
+    resolve_global_procedure (sym, &expr->where, 0);
 
   if (sym && sym->ts.type == BT_CHARACTER
       && sym->ts.u.cl
@@ -3675,7 +3665,7 @@ resolve_call (gfc_code *c)
 
   /* If external, check for usage.  */
   if (csym && is_external_proc (csym))
-    resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
+    resolve_global_procedure (csym, &c->loc, 1);
 
   t = true;
   if (c->resolved_sym == NULL)
Index: testsuite/gfortran.dg/altreturn_10.f90
===================================================================
--- testsuite/gfortran.dg/altreturn_10.f90	(Revision 274370)
+++ testsuite/gfortran.dg/altreturn_10.f90	(Arbeitskopie)
@@ -14,6 +14,6 @@ subroutine sub (x)
 end
 subroutine sub2
    call sub (*99) ! { dg-error "Unexpected alternate return specifier" }
-   call sub (99.) ! { dg-warning "Type mismatch in argument" }
+   call sub (99.) ! { dg-error "Type mismatch in argument" }
 99 stop
 end
Index: testsuite/gfortran.dg/dec_union_11.f90
===================================================================
--- testsuite/gfortran.dg/dec_union_11.f90	(Revision 274370)
+++ testsuite/gfortran.dg/dec_union_11.f90	(Arbeitskopie)
@@ -1,5 +1,5 @@
 ! { dg-do compile }
-! { dg-options "-g -fdec-structure" }
+! { dg-options "-g -fdec-structure -std=legacy" }
 !
 ! Test a regression where typespecs of unions containing character buffers of
 ! different lengths where copied, resulting in a bad gimple tree state.
Index: testsuite/gfortran.dg/hollerith8.f90
===================================================================
--- testsuite/gfortran.dg/hollerith8.f90	(Revision 274370)
+++ testsuite/gfortran.dg/hollerith8.f90	(Arbeitskopie)
@@ -1,9 +1,9 @@
 ! { dg-do run }
-! { dg-options "-std=gnu" }
+! { dg-options "-std=legacy" }
 ! PR43217 Output of Hollerith constants which are not a multiple of 4 bytes
 ! Test case prepared from OP by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 program hello2
-  call wrtout (9hHELLO YOU, 9)
+  call wrtout (9hHELLO YOU, 9) ! { dg-warning "Rank mismatch" }
   stop
 end
 
@@ -22,5 +22,3 @@ subroutine wrtout (iarray, nchrs)
  &    outstr.ne."48454C4C 4F20594F 55202020") STOP 1
   return
 end
-! { dg-warning "Hollerith constant" "" { target *-*-* } 6 }
-! { dg-warning "Rank mismatch" "" { target *-*-* } 6 }
Index: testsuite/gfortran.dg/integer_exponentiation_2.f90
===================================================================
--- testsuite/gfortran.dg/integer_exponentiation_2.f90	(Revision 274370)
+++ testsuite/gfortran.dg/integer_exponentiation_2.f90	(Arbeitskopie)
@@ -139,16 +139,16 @@ subroutine foo(a)
   call gee_i(i**(-huge(0_4)))
   call gee_i(i**(-huge(0_4)-1_4))
 
-  call gee_i(i**0_8) ! { dg-warning "Type mismatch in argument" }
-  call gee_i(i**1_8) ! { dg-warning "Type mismatch in argument" }
-  call gee_i(i**2_8) ! { dg-warning "Type mismatch in argument" }
-  call gee_i(i**3_8) ! { dg-warning "Type mismatch in argument" }
-  call gee_i(i**(-1_8)) ! { dg-warning "Type mismatch in argument" }
-  call gee_i(i**(-2_8)) ! { dg-warning "Type mismatch in argument" }
-  call gee_i(i**(-3_8)) ! { dg-warning "Type mismatch in argument" }
-  call gee_i(i**huge(0_8)) ! { dg-warning "Type mismatch in argument" }
-  call gee_i(i**(-huge(0_8))) ! { dg-warning "Type mismatch in argument" }
-  call gee_i(i**(-huge(0_8)-1_8)) ! { dg-warning "Type mismatch in argument" }
+  call gee_i8(i**0_8)
+  call gee_i8(i**1_8)
+  call gee_i8(i**2_8)
+  call gee_i8(i**3_8)
+  call gee_i8(i**(-1_8))
+  call gee_i8(i**(-2_8))
+  call gee_i8(i**(-3_8))
+  call gee_i8(i**huge(0_8))
+  call gee_i8(i**(-huge(0_8)))
+  call gee_i8(i**(-huge(0_8)-1_8))
 
   ! Real
   call gee_r(a**0_1)
@@ -245,6 +245,10 @@ subroutine gee_i(i)
   integer :: i
 end subroutine gee_i
 
+subroutine gee_i8(i)
+  integer(kind=8) :: i
+end subroutine gee_i8
+
 subroutine gee_r(r)
   real :: r
 end subroutine gee_r
Index: testsuite/gfortran.dg/pr41011.f
===================================================================
--- testsuite/gfortran.dg/pr41011.f	(Revision 274370)
+++ testsuite/gfortran.dg/pr41011.f	(Arbeitskopie)
@@ -1,5 +1,5 @@
 ! { dg-do compile }
-! { dg-options "-O3" }
+! { dg-options "-O3 -std=legacy" }
       CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch" }
      *ITY,ISH,NSMT,F)
          CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA,
Index: testsuite/gfortran.dg/whole_file_1.f90
===================================================================
--- testsuite/gfortran.dg/whole_file_1.f90	(Revision 274370)
+++ testsuite/gfortran.dg/whole_file_1.f90	(Arbeitskopie)
@@ -19,7 +19,7 @@ subroutine b
     integer :: u1
   end type
   type (u) :: q
-  call a(q)  ! { dg-warning "Type mismatch" }
+  call a(q)  ! { dg-error "Type mismatch" }
   print *, q%u1
 end subroutine
 
@@ -36,7 +36,7 @@ subroutine d
     integer :: u1
   end type
   type (u) :: q
-  call c(q)  ! { dg-warning "Type mismatch" }
+  call c(q)  ! { dg-error "Type mismatch" }
   print *, q%u1
 end subroutine
 
Index: testsuite/gfortran.dg/whole_file_2.f90
===================================================================
--- testsuite/gfortran.dg/whole_file_2.f90	(Revision 274370)
+++ testsuite/gfortran.dg/whole_file_2.f90	(Arbeitskopie)
@@ -14,8 +14,8 @@ end function
 program gg
 real :: h
 character (5) :: chr = 'hello'
-h = a(); ! { dg-warning "Missing actual argument" }
-call test ([chr]) ! { dg-warning "Rank mismatch" }
+h = a(); ! { dg-error "Missing actual argument" }
+call test ([chr]) ! { dg-error "Rank mismatch" }
 end program gg
 
 subroutine test (a)
! { dg-do compile }
! PR 91443 - this was not caught.
module x
contains
  subroutine a
    call foo(1) ! { dg-error "Type mismatch in argument" }
  end subroutine a
end module x

subroutine foo(a)
  real :: a
  print *,a
end subroutine foo

program main
  use x
  call a
end program main

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]