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, 44 insertions, 32 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f214050..25834f8 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1141,6 +1141,34 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
 }
 
 
+/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
+   its typespec and formal argument list.  */
+
+static gfc_try
+resolve_intrinsic (gfc_symbol *sym, locus *loc)
+{
+  gfc_intrinsic_sym *isym = gfc_find_function (sym->name);
+  if (isym)
+    {
+      if (!sym->attr.function &&
+	  gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
+	return FAILURE;
+      sym->ts = isym->ts;
+    }
+  else
+    {
+      isym = gfc_find_subroutine (sym->name);
+      gcc_assert (isym);
+      if (!sym->attr.subroutine &&
+	  gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
+	return FAILURE;
+    }
+  if (!sym->formal)
+    gfc_copy_formal_args_intr (sym, isym);
+  return SUCCESS;
+}
+
+
 /* Resolve a procedure expression, like passing it to a called procedure or as
    RHS for a procedure pointer assignment.  */
 
@@ -1154,6 +1182,10 @@ resolve_procedure_expression (gfc_expr* expr)
   gcc_assert (expr->symtree);
 
   sym = expr->symtree->n.sym;
+
+  if (sym->attr.intrinsic)
+    resolve_intrinsic (sym, &expr->where);
+
   if (sym->attr.flavor != FL_PROCEDURE
       || (sym->attr.function && sym->result == sym))
     return SUCCESS;
@@ -2318,14 +2350,8 @@ resolve_function (gfc_expr *expr)
     sym = expr->symtree->n.sym;
 
   if (sym && sym->attr.intrinsic
-      && !gfc_find_function (sym->name)
-      && gfc_find_subroutine (sym->name)
-      && sym->attr.function)
-    {
-      gfc_error ("Intrinsic subroutine '%s' used as "
-		  "a function at %L", sym->name, &expr->where);
-      return FAILURE;
-    }
+      && resolve_intrinsic (sym, &expr->where) == FAILURE)
+    return FAILURE;
 
   if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
     {
@@ -9193,6 +9219,9 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
+    gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
+
   if (sym->attr.procedure && sym->ts.interface
       && sym->attr.if_source != IFSRC_DECL)
     {
@@ -9207,30 +9236,13 @@ resolve_symbol (gfc_symbol *sym)
 	  gfc_symbol *ifc = sym->ts.interface;
 
 	  if (ifc->attr.intrinsic)
-	    {
-	      gfc_intrinsic_sym *isym = gfc_find_function (sym->ts.interface->name);
-	      if (isym)
-		{
-		  sym->attr.function = 1;
-		  sym->ts = isym->ts;
-		  sym->ts.interface = ifc;
-		}
-	      else
-		{
-		  isym = gfc_find_subroutine (sym->ts.interface->name);
-		  gcc_assert (isym);
-		  sym->attr.subroutine = 1;
-		}
-	      copy_formal_args_intr (sym, isym);
-	    }
-	  else
-	    {
-	      sym->ts = ifc->ts;
-	      sym->ts.interface = ifc;
-	      sym->attr.function = ifc->attr.function;
-	      sym->attr.subroutine = ifc->attr.subroutine;
-	      copy_formal_args (sym, ifc);
-	    }
+	    resolve_intrinsic (ifc, &ifc->declared_at);
+
+	  sym->ts = ifc->ts;
+	  sym->ts.interface = ifc;
+	  sym->attr.function = ifc->attr.function;
+	  sym->attr.subroutine = ifc->attr.subroutine;
+	  gfc_copy_formal_args (sym, ifc);
 
 	  sym->attr.allocatable = ifc->attr.allocatable;
 	  sym->attr.pointer = ifc->attr.pointer;