re PR fortran/51081 ([F03] Proc-pointer assignment: Rejects valid internal proc)

2012-07-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/51081
	* gfortran.h (gfc_resolve_intrinsic): Add prototype.
	* expr.c (gfc_check_pointer_assign): Set INTRINSIC attribute if needed.
	Check for invalid intrinsics.
	* primary.c (gfc_match_rvalue): Check for intrinsics came too early.
	Set procedure flavor if appropriate.
	* resolve.c (resolve_intrinsic): Renamed to gfc_resolve_intrinsic.
	(resolve_procedure_interface,resolve_procedure_expression,
	resolve_function,resolve_fl_derived0,resolve_symbol): Ditto.

2012-07-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/51081
	* gfortran.dg/proc_ptr_37.f90: New.

From-SVN: r189985

gcc/fortran/ChangeLog

+2012-07-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/51081
+	* gfortran.h (gfc_resolve_intrinsic): Add prototype.
+	* expr.c (gfc_check_pointer_assign): Set INTRINSIC attribute if needed.
+	Check for invalid intrinsics.
+	* primary.c (gfc_match_rvalue): Check for intrinsics came too early.
+	Set procedure flavor if appropriate.
+	* resolve.c (resolve_intrinsic): Renamed to gfc_resolve_intrinsic.
+	(resolve_procedure_interface,resolve_procedure_expression,
+	resolve_function,resolve_fl_derived0,resolve_symbol): Ditto.
+
 2012-07-26  Mikael Morin  <mikael@gcc.gnu.org>
 
 	PR fortran/44354

gcc/fortran/expr.c

@@ -3421,6 +3421,21 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 		     &rvalue->where);
 	  return FAILURE;
 	}
+      if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
+	{
+      	  /* Check for intrinsics.  */
+	  gfc_symbol *sym = rvalue->symtree->n.sym;
+	  if (!sym->attr.intrinsic
+	      && !(sym->attr.contained || sym->attr.use_assoc
+		   || sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
+	      && (gfc_is_intrinsic (sym, 0, sym->declared_at)
+		  || gfc_is_intrinsic (sym, 1, sym->declared_at)))
+	    {
+	      sym->attr.intrinsic = 1;
+	      gfc_resolve_intrinsic (sym, &rvalue->where);
+	      attr = gfc_expr_attr (rvalue);
+	    }
+	}
       if (attr.abstract)
 	{
 	  gfc_error ("Abstract interface '%s' is invalid "
@@ -3444,6 +3459,13 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 			      "at %L", rvalue->symtree->name, &rvalue->where)
 			      == FAILURE)
 	    return FAILURE;
+	  if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
+							 attr.subroutine) == 0)
+	    {
+	      gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
+			 "assignment", rvalue->symtree->name, &rvalue->where);
+	      return FAILURE;
+	    }
 	}
       /* Check for F08:C730.  */
       if (attr.elemental && !attr.intrinsic)

gcc/fortran/gfortran.h

@@ -2805,7 +2805,8 @@ int gfc_is_formal_arg (void);
 void gfc_resolve_substring_charlen (gfc_expr *);
 match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
 gfc_expr *gfc_expr_to_initialize (gfc_expr *);
-bool gfc_type_is_extensible (gfc_symbol *sym);
+bool gfc_type_is_extensible (gfc_symbol *);
+gfc_try gfc_resolve_intrinsic (gfc_symbol *, locus *);
 
 
 /* array.c */

gcc/fortran/primary.c

@@ -2843,13 +2843,18 @@ gfc_match_rvalue (gfc_expr **result)
 	    /* Parse functions returning a procptr.  */
 	    goto function0;
 
-	  if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
-	      || gfc_is_intrinsic (sym, 1, gfc_current_locus))
-	    sym->attr.intrinsic = 1;
 	  e = gfc_get_expr ();
 	  e->expr_type = EXPR_VARIABLE;
 	  e->symtree = symtree;
 	  m = gfc_match_varspec (e, 0, false, true);
+	  if (!e->ref && sym->attr.flavor == FL_UNKNOWN
+	      && sym->ts.type == BT_UNKNOWN
+	      && gfc_add_flavor (&sym->attr, FL_PROCEDURE,
+				 sym->name, NULL) == FAILURE)
+	    {
+	      m = MATCH_ERROR;
+	      break;
+	    }
 	  break;
 	}
 

gcc/fortran/resolve.c

@@ -139,7 +139,6 @@ resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
 
 
 static void resolve_symbol (gfc_symbol *sym);
-static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
 
 
 /* Resolve the interface for a PROCEDURE declaration or procedure pointer.  */
@@ -168,7 +167,7 @@ resolve_procedure_interface (gfc_symbol *sym)
       resolve_symbol (ifc);
 
       if (ifc->attr.intrinsic)
-	resolve_intrinsic (ifc, &ifc->declared_at);
+	gfc_resolve_intrinsic (ifc, &ifc->declared_at);
 
       if (ifc->result)
 	{
@@ -1499,8 +1498,8 @@ 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_try
+gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
 {
   gfc_intrinsic_sym* isym = NULL;
   const char* symstd;
@@ -1588,7 +1587,7 @@ resolve_procedure_expression (gfc_expr* expr)
   sym = expr->symtree->n.sym;
 
   if (sym->attr.intrinsic)
-    resolve_intrinsic (sym, &expr->where);
+    gfc_resolve_intrinsic (sym, &expr->where);
 
   if (sym->attr.flavor != FL_PROCEDURE
       || (sym->attr.function && sym->result == sym))
@@ -3064,7 +3063,7 @@ resolve_function (gfc_expr *expr)
     return SUCCESS;
   
   if (sym && sym->attr.intrinsic
-      && resolve_intrinsic (sym, &expr->where) == FAILURE)
+      && gfc_resolve_intrinsic (sym, &expr->where) == FAILURE)
     return FAILURE;
 
   if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
@@ -11884,7 +11883,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
 		resolve_symbol (ifc);
 
 	      if (ifc->attr.intrinsic)
-		resolve_intrinsic (ifc, &ifc->declared_at);
+		gfc_resolve_intrinsic (ifc, &ifc->declared_at);
 
 	      if (ifc->result)
 		{
@@ -12519,7 +12518,7 @@ resolve_symbol (gfc_symbol *sym)
      representation. This needs to be done before assigning a default 
      type to avoid spurious warnings.  */
   if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
-      && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
+      && gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
     return;
 
   /* Resolve associate names.  */

gcc/testsuite/ChangeLog

+2012-07-30  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/51081
+	* gfortran.dg/proc_ptr_37.f90: New.
+
 2012-07-30  Ulrich Weigand  <ulrich.weigand@linaro.org>
 
 	* lib/target-supports.exp

gcc/testsuite/gfortran.dg/proc_ptr_37.f90

+! { dg-do compile }
+!
+! PR 51081: [F03] Proc-pointer assignment: Rejects valid internal proc
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+procedure(), pointer :: p1
+procedure(real), pointer :: p2
+p1 => int2
+p2 => scale   ! { dg-error "is invalid in procedure pointer assignment" }
+contains
+  subroutine int2()
+    print *,"..."
+  end subroutine
+end