re PR fortran/39735 (procedure pointer assignments: return value is not checked)

2009-04-22  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39735
	* decl.c (add_hidden_procptr_result): Bugfix for procptr results.
	(match_procedure_decl): Set if_source.
	* expr.c (gfc_check_pointer_assign): Bugfix: Return after error.
	And: Check interface also for IFSRC_UNKNOWN (return type may be known).
	* gfortran.h (typedef enum ifsrc): Remove IFSRC_USAGE,
	add documentation. Rename copy_formal_args and copy_formal_args_intr.
	* interface.c (gfc_compare_interfaces): Check for return types,
	handle IFSRC_UNKNOWN.
	(compare_intr_interfaces,compare_actual_formal_intr): Obsolete, removed.
	(gfc_procedure_use): Modified handling of intrinsics.
	* intrinsic.c (add_functions): Bugfix for "dim".
	* resolve.c (resolve_intrinsic): New function to resolve intrinsics,
	which copies the interface from isym to sym.
	(resolve_procedure_expression,resolve_function): Use new function
	'resolve_intrinsic'.
	(resolve_symbol): Add function attribute for externals with return type
	and use new function 'resolve_intrinsic'.
	* symbol.c (ifsrc_types): Remove string for IFSRC_USAGE.
	(copy_formal_args): Renamed to gfc_copy_formal_args.
	(copy_formal_args_intr): Renamed to gfc_copy_formal_args_intr.
	* trans-const.c (gfc_conv_const_charlen): Handle cl==NULL.


2009-04-22  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39735
	* gfortran.dg/assumed_charlen_function_5.f90: Modified.
	* gfortran.dg/external_initializer.f90: Modified.
	* gfortran.dg/interface_26.f90: Modified.
	* gfortran.dg/intrinsic_subroutine.f90: Modified.
	* gfortran.dg/proc_ptr_3.f90: Modified.
	* gfortran.dg/proc_ptr_15.f90: New.
	* gfortran.dg/proc_ptr_result_1.f90: Modified.

From-SVN: r146554

1 files changed, 20 insertions, 147 deletions

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 162816c..489386c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -479,8 +479,6 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
 }
 
 
-static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
-
 /* Given two symbols that are formal arguments, compare their types
    and rank and their formal interfaces if they are both dummy
    procedures.  Returns nonzero if the same, zero if different.  */
@@ -967,155 +965,44 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
 {
   gfc_formal_arglist *f1, *f2;
 
-  if (s2->attr.intrinsic)
-    return compare_intr_interfaces (s1, s2);
-
-  if (s1->attr.function != s2->attr.function
-      || s1->attr.subroutine != s2->attr.subroutine)
-    return 0;		/* Disagreement between function/subroutine.  */
-
-  f1 = s1->formal;
-  f2 = s2->formal;
-
-  if (f1 == NULL && f2 == NULL)
-    return 1;			/* Special case.  */
-
-  if (count_types_test (f1, f2))
+  if ((s1->attr.function && !s2->attr.function)
+      || (s1->attr.subroutine && s2->attr.function))
     return 0;
-  if (count_types_test (f2, f1))
-    return 0;
-
-  if (generic_flag)
-    {
-      if (generic_correspondence (f1, f2))
-	return 0;
-      if (generic_correspondence (f2, f1))
-	return 0;
-    }
-  else
-    {
-      if (operator_correspondence (f1, f2))
-	return 0;
-    }
-
-  return 1;
-}
-
-
-static int
-compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
-{
-  gfc_formal_arglist *f, *f1;
-  gfc_intrinsic_arg *fi, *f2;
-  gfc_intrinsic_sym *isym;
-
-  isym = gfc_find_function (s2->name);
-  if (isym)
-    {
-      if (!s2->attr.function)
-	gfc_add_function (&s2->attr, s2->name, &gfc_current_locus);
-      s2->ts = isym->ts;
-    }
-  else
-    {
-      isym = gfc_find_subroutine (s2->name);
-      gcc_assert (isym);
-      if (!s2->attr.subroutine)
-	gfc_add_subroutine (&s2->attr, s2->name, &gfc_current_locus);
-    }
 
-  if (s1->attr.function != s2->attr.function
-      || s1->attr.subroutine != s2->attr.subroutine)
-    return 0;		/* Disagreement between function/subroutine.  */
-  
-  /* If the arguments are functions, check type and kind.  */
-  
-  if (s1->attr.dummy && s1->attr.function && s2->attr.function)
+  /* If the arguments are functions, check type and kind
+     (only for dummy procedures and procedure pointer assignments).  */
+  if ((s1->attr.dummy || s1->attr.proc_pointer)
+      && s1->attr.function && s2->attr.function)
     {
-      if (s1->ts.type != s2->ts.type)
-	return 0;
-      if (s1->ts.kind != s2->ts.kind)
+      if (s1->ts.type == BT_UNKNOWN)
+	return 1;
+      if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
 	return 0;
       if (s1->attr.if_source == IFSRC_DECL)
 	return 1;
     }
 
-  f1 = s1->formal;
-  f2 = isym->formal;
-
-  /* Special case.  */
-  if (f1 == NULL && f2 == NULL)
+  if (s1->attr.if_source == IFSRC_UNKNOWN)
     return 1;
-  
-  /* First scan through the formal argument list and check the intrinsic.  */
-  fi = f2;
-  for (f = f1; f; f = f->next)
-    {
-      if (fi == NULL)
-	return 0;
-      if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
-	return 0;
-      fi = fi->next;
-    }
-
-  /* Now scan through the intrinsic argument list and check the formal.  */
-  f = f1;
-  for (fi = f2; fi; fi = fi->next)
-    {
-      if (f == NULL)
-	return 0;
-      if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
-	return 0;
-      f = f->next;
-    }
-
-  return 1;
-}
 
+  f1 = s1->formal;
+  f2 = s2->formal;
 
-/* Compare an actual argument list with an intrinsic argument list.  */
-
-static int
-compare_actual_formal_intr (gfc_actual_arglist **ap, gfc_symbol *s2)
-{
-  gfc_actual_arglist *a;
-  gfc_intrinsic_arg *fi, *f2;
-  gfc_intrinsic_sym *isym;
-
-  isym = gfc_find_function (s2->name);
-  
-  /* This should already have been checked in
-     resolve.c (resolve_actual_arglist).  */
-  gcc_assert (isym);
+  if (f1 == NULL && f2 == NULL)
+    return 1;			/* Special case.  */
 
-  f2 = isym->formal;
+  if (count_types_test (f1, f2) || count_types_test (f2, f1))
+    return 0;
 
-  /* Special case.  */
-  if (*ap == NULL && f2 == NULL)
-    return 1;
-  
-  /* First scan through the actual argument list and check the intrinsic.  */
-  fi = f2;
-  for (a = *ap; a; a = a->next)
+  if (generic_flag)
     {
-      if (fi == NULL)
+      if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
 	return 0;
-      if ((fi->ts.type != a->expr->ts.type)
-	  || (fi->ts.kind != a->expr->ts.kind))
-	return 0;
-      fi = fi->next;
     }
-
-  /* Now scan through the intrinsic argument list and check the formal.  */
-  a = *ap;
-  for (fi = f2; fi; fi = fi->next)
+  else
     {
-      if (a == NULL)
-	return 0;
-      if ((fi->ts.type != a->expr->ts.type)
-	  || (fi->ts.kind != a->expr->ts.kind))
+      if (operator_correspondence (f1, f2))
 	return 0;
-      a = a->next;
     }
 
   return 1;
@@ -2436,20 +2323,6 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
     gfc_warning ("Procedure '%s' called with an implicit interface at %L",
 		 sym->name, where);
 
-  if (sym->ts.interface && sym->ts.interface->attr.intrinsic)
-    {
-      gfc_intrinsic_sym *isym;
-      isym = gfc_find_function (sym->ts.interface->name);
-      if (isym != NULL)
-	{
-	  if (compare_actual_formal_intr (ap, sym->ts.interface))
-	    return;
-	  gfc_error ("Type/rank mismatch in argument '%s' at %L",
-		     sym->name, where);
-	  return;
-	}
-    }
-
   if (sym->attr.if_source == IFSRC_UNKNOWN)
     {
       gfc_actual_arglist *a;