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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0c0ffe054589ea899a6bbaf3ab35f56b826e3299..4974cb34d6b43281d113360eb838b60f31a30563 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+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

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index cb5e1c665614832c606b6d5fc6592483c7ddde91..f43bc6f8a99b277a1cb18d6900052476dc8ac68d 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/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)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index e1f2e3c7cc694e74c3018aff430e50ef1d862bc4..063959a8df986d8722dac5b06cdae78b6e1075a7 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/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 */

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index e2c3f9917c33652490aca9c2890a983c2d512157..29d278911cd0d6ecb158e5cd9e7f3be59f132c28 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/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;
        }
 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 370e5cd8d36283a1d9e4015a537e47750572c9db..25c6c8ec00d60baca488103bbf91618c4f7dd3cd 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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.  */

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 442aa3fda958f0db5676cb3fde0955457f49f1cb..1ee69471d29ad2b097a721d337c4946c52d5c9ae 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_37.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_37.f90
new file mode 100644 (file)
index 0000000..485e76f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_37.f90
@@ -0,0 +1,15 @@
+! { 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