[Patch, Fortran, OOP] PR 48095: Invalid assignment to procedure pointer component not rejected

[Janus Weil <janus at gcc dot gnu dot org>]

Hi all,

the attached patch fixes a problem with assignments to procedure
pointer components: The checking for such assignments did only work
within one module, but not across modules. The reason for this was
that the "ts.interface" field was not being written to the module
file.

The patch fixes this by writing the field to the mod file. It also
bumps the module version number and takes care of a few regression
introduced by the former change. It fixes comment #3 in the PR, which
is included as a test case. There is a remaining problem in the PR
(related the pointer initialization) which I will take care of
subsequently.

The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2011-03-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/48095
	* decl.c (match_procedure_decl,match_ppc_decl): Set flavor of interface.
	* module.c (MOD_VERSION): Bump.
	(mio_typespec): Read/write 'interface' field.
	* primary.c (match_string_constant,match_logical_constant): Remove
	unneeded code.
	(match_complex_constant): Make sure to clear the typespec.

2011-03-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/48095
	* gfortran.dg/module_md5_1.f90: Modified MD5 sum.
	* gfortran.dg/proc_ptr_comp_32.f90: New.

Index: gcc/testsuite/gfortran.dg/module_md5_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/module_md5_1.f90	(revision 171617)
+++ gcc/testsuite/gfortran.dg/module_md5_1.f90	(working copy)
@@ -10,5 +10,5 @@ program test
   use foo
   print *, pi
 end program test
-! { dg-final { scan-module "foo" "MD5:5632bcd379cf023bf7e663e91d52fa12" } }
+! { dg-final { scan-module "foo" "MD5:12a205c48fe46315a609823f15986377" } }
 ! { dg-final { cleanup-modules "foo" } }
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 171617)
+++ gcc/fortran/decl.c	(working copy)
@@ -4737,8 +4737,9 @@ match_procedure_decl (void)
 	    return MATCH_ERROR;
 	  sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
 	  sym->ts.interface->ts = current_ts;
+	  sym->ts.interface->attr.flavor = FL_PROCEDURE;
 	  sym->ts.interface->attr.function = 1;
-	  sym->attr.function = sym->ts.interface->attr.function;
+	  sym->attr.function = 1;
 	  sym->attr.if_source = IFSRC_UNKNOWN;
 	}
 
@@ -4871,8 +4872,9 @@ match_ppc_decl (void)
 	  c->ts = ts;
 	  c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
 	  c->ts.interface->ts = ts;
+	  c->ts.interface->attr.flavor = FL_PROCEDURE;
 	  c->ts.interface->attr.function = 1;
-	  c->attr.function = c->ts.interface->attr.function;
+	  c->attr.function = 1;
 	  c->attr.if_source = IFSRC_UNKNOWN;
 	}
 
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 171617)
+++ gcc/fortran/module.c	(working copy)
@@ -80,7 +80,7 @@ along with GCC; see the file COPYING3.  If not see
 
 /* Don't put any single quote (') in MOD_VERSION, 
    if yout want it to be recognized.  */
-#define MOD_VERSION "6"
+#define MOD_VERSION "7"
 
 
 /* Structure that describes a position within a module file.  */
@@ -2124,6 +2124,8 @@ mio_typespec (gfc_typespec *ts)
   else
     mio_symbol_ref (&ts->u.derived);
 
+  mio_symbol_ref (&ts->interface);
+
   /* Add info for C interop and is_iso_c.  */
   mio_integer (&ts->is_c_interop);
   mio_integer (&ts->is_iso_c);
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 171617)
+++ gcc/fortran/primary.c	(working copy)
@@ -980,9 +980,6 @@ got_delim:
     goto no_match;
 
   e = gfc_get_character_expr (kind, &start_locus, NULL, length);
-  e->ref = NULL;
-  e->ts.is_c_interop = 0;
-  e->ts.is_iso_c = 0;
 
   gfc_current_locus = start_locus;
 
@@ -1086,8 +1083,6 @@ match_logical_constant (gfc_expr **result)
     }
 
   e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
-  e->ts.is_c_interop = 0;
-  e->ts.is_iso_c = 0;
 
   *result = e;
   return MATCH_YES;
@@ -1269,10 +1264,9 @@ match_complex_constant (gfc_expr **result)
       else
 	kind = gfc_default_real_kind;
     }
+  gfc_clear_ts (&target);
   target.type = BT_REAL;
   target.kind = kind;
-  target.is_c_interop = 0;
-  target.is_iso_c = 0;
 
   if (real->ts.type != BT_REAL || kind != real->ts.kind)
     gfc_convert_type (real, &target, 2);

! { dg-do compile }
!
! PR 48095: [OOP] Invalid assignment to procedure pointer component not rejected
!
! Contributed by Arjen Markus <arjen.markus895@gmail.com>

module m

  implicit none

  type :: rectangle
    procedure(get_area), pointer :: get_special_area
  end type rectangle

  abstract interface
    real function get_area( this )
      import                       :: rectangle
      class(rectangle), intent(in) :: this
    end function get_area
  end interface

contains

  real function get_my_area( this )
    type(rectangle), intent(in) :: this
    get_my_area = 3.0
  end function get_my_area

end module


use m
type(rectangle) :: rect
rect%get_special_area => get_my_area  ! { dg-error "Interface mismatch in procedure pointer assignment" }
end

! { dg-final { cleanup-modules "m" } }