re PR fortran/91443 (-Wargument-mismatch does not catch mismatch for global procedure)

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.

From-SVN: r274551

gcc/fortran/ChangeLog

+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-13  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/87991
@@ -7,7 +25,7 @@
 2019-08-13  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/88072
-	* misc.c (gfc_typename): Do not point to something that ought not to 
+	* misc.c (gfc_typename): Do not point to something that ought not to
 	be pointed at.
 
 2013-08-13  Thomas Koenig  <tkoenig@gcc.gnu.org>

gcc/fortran/frontend-passes.c

@@ -56,7 +56,6 @@ static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *,
 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 codefn, walk_expr_fn_t exprfn,
     }
   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);
+}

gcc/fortran/gfortran.h

@@ -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 *, void *);
 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 */
 

gcc/fortran/interface.c

@@ -2979,10 +2979,15 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
       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_arglist **ap, locus *where)
 
       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_arglist **ap, locus *where)
 	      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_arglist **ap, locus *where)
 	      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,13 +3774,16 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 	      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;
 	    }
 
 	  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_arglist **ap, locus *where)
 	    {
 	      gfc_error ("Assumed-rank argument requires an explicit interface "
 			 "at %L", &a->expr->where);
+	      a->expr->error = 1;
 	      return false;
 	    }
 	}

gcc/fortran/parse.c

@@ -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;
 

gcc/fortran/resolve.c

@@ -2506,8 +2506,7 @@ gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
 
 
 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 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
 			 " %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)

gcc/testsuite/ChangeLog

+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.
+
 2019-08-15  Richard Biener  <rguenther@suse.de>
 
 	PR tree-optimization/91445

gcc/testsuite/gfortran.dg/altreturn_10.f90

@@ -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

gcc/testsuite/gfortran.dg/argument_checking_19.f90

+! { 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

gcc/testsuite/gfortran.dg/dec_union_11.f90

 ! { 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.

gcc/testsuite/gfortran.dg/hollerith8.f90

 ! { 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 }

gcc/testsuite/gfortran.dg/integer_exponentiation_2.f90

@@ -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

gcc/testsuite/gfortran.dg/pr41011.f

 ! { 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,

gcc/testsuite/gfortran.dg/whole_file_1.f90

@@ -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
 

gcc/testsuite/gfortran.dg/whole_file_2.f90

@@ -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)