This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, Fortran] PR 39735: procedure pointer assignments: return value is not checked


Hi all,

here is my patch for PR 39735, which has become a bit larger than
expected. Its primary purpose is to add a check for procedure pointer
assignments, which makes sure that the assigned procedure has the
right return type. Other checks have already been added with PR 38290
(cf. proc_ptr_11.f90).

Connected to this main goal, the patch includes some further changes:

1) It modifies the handling of intrinsic procedures. In particular it
adds a function "resolve_intrinsic", which copies the return type and
formal args from the isym to the sym, and sets the function/subroutine
attribute. Thereby it obsoletes the functions
"compare_intr_interfaces" and "compare_actual_formal_intr", because
intrinsic procedures can now be handled just like other procedures in
this respect.

2) It modifies a number of existing test cases. While for some of them
just the wording of the error message is modified, at least four are
real errors which have not been detected before.

3) It fixes a bug in the implementation of procedure pointer return
values (PR 36704), which was revealed by the extended checking.

4) It fixes a bug (?) in the "dim" intrinsic (see intrinsic.c).

5) It removes IFSRC_USAGE (if someone has a reason why this should be
kept, please protest!), and adds some documentation for the other
IFSRC_* values in gfortran.h.

Regression-tested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2009-04-16  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.
	* 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.
	* trans-const.c (gfc_conv_const_charlen): Handle cl==NULL.


2009-04-16  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.
Index: gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90	(Revision 146125)
+++ gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90	(Arbeitskopie)
@@ -8,6 +8,7 @@ module mo
 contains
 
   function j()
+    implicit none
     procedure(),pointer :: j
     intrinsic iabs
     j => iabs
Index: gcc/testsuite/gfortran.dg/interface_26.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_26.f90	(Revision 146125)
+++ gcc/testsuite/gfortran.dg/interface_26.f90	(Arbeitskopie)
@@ -37,7 +37,7 @@ CONTAINS
     END INTERFACE
     INTEGER, EXTERNAL :: UserOp 
 
-    res = UserFunction( a,b, UserOp )
+    res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in argument" }
 
     if( res .lt. 10 ) then
        res = recSum( a, res, UserFunction, UserOp ) 
Index: gcc/testsuite/gfortran.dg/external_initializer.f90
===================================================================
--- gcc/testsuite/gfortran.dg/external_initializer.f90	(Revision 146125)
+++ gcc/testsuite/gfortran.dg/external_initializer.f90	(Arbeitskopie)
@@ -1,5 +1,5 @@
 ! { dg-do compile }
 ! PR20849 - An external symbol may not have a initializer.
 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
-REAL, EXTERNAL :: X=0 ! { dg-error "may not have an initializer" }
+REAL, EXTERNAL :: X=0 ! { dg-error "not have an initializer" }
 END
Index: gcc/testsuite/gfortran.dg/assumed_charlen_function_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/assumed_charlen_function_5.f90	(Revision 146125)
+++ gcc/testsuite/gfortran.dg/assumed_charlen_function_5.f90	(Arbeitskopie)
@@ -12,7 +12,7 @@ end function charrext
 
   character(26), external :: charrext
   interface
-    integer(4) function test(charr, i)
+    integer(4) function test(charr, i)  ! { dg-warning "is obsolescent in fortran 95" }
      character(*), external :: charr
      integer :: i
     end function test
@@ -36,4 +36,5 @@ integer(4) function test(charr, i)  ! { 
   integer :: i
   print *, charr(i)
   test = 1
-end function test
\ Kein Zeilenumbruch am Dateiende.
+end function test
+
Index: gcc/testsuite/gfortran.dg/intrinsic_subroutine.f90
===================================================================
--- gcc/testsuite/gfortran.dg/intrinsic_subroutine.f90	(Revision 146125)
+++ gcc/testsuite/gfortran.dg/intrinsic_subroutine.f90	(Arbeitskopie)
@@ -3,5 +3,5 @@
 implicit none
 intrinsic cpu_time
 real :: time
-print *, CPU_TIME(TIME)  ! { dg-error "Intrinsic subroutine" }
+print *, CPU_TIME(TIME)  ! { dg-error "attribute conflicts with" }
 end
Index: gcc/testsuite/gfortran.dg/proc_ptr_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_3.f90	(Revision 146125)
+++ gcc/testsuite/gfortran.dg/proc_ptr_3.f90	(Arbeitskopie)
@@ -27,7 +27,7 @@ interface
   end subroutine sp
 end interface
 
-external :: e1
+real, external :: e1
 
 interface
   subroutine e2(a,b)
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(Revision 146125)
+++ gcc/fortran/interface.c	(Arbeitskopie)
@@ -479,8 +479,6 @@ compare_type_rank (gfc_symbol *s1, gfc_s
 }
 
 
-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_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))
-    return 0;
-  if (count_types_test (f2, f1))
+  if ((s1->attr.function && !s2->attr.function)
+      || (s1->attr.subroutine && s2->attr.function))
     return 0;
 
-  if (generic_flag)
+  /* 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 (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 (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;
-}
-
-
-/* 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;
+  f1 = s1->formal;
+  f2 = s2->formal;
 
-  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_
     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;
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(Revision 146125)
+++ gcc/fortran/intrinsic.c	(Arbeitskopie)
@@ -1362,7 +1362,7 @@ add_functions (void)
 
   add_sym_2 ("dim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
 	     gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
-	     x, BT_REAL, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
+	     x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
 
   add_sym_2 ("idim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
 	     NULL, gfc_simplify_dim, gfc_resolve_dim,
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 146125)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -75,8 +75,7 @@ const mstring ifsrc_types[] =
 {
     minit ("UNKNOWN", IFSRC_UNKNOWN),
     minit ("DECL", IFSRC_DECL),
-    minit ("BODY", IFSRC_IFBODY),
-    minit ("USAGE", IFSRC_USAGE)
+    minit ("BODY", IFSRC_IFBODY)
 };
 
 const mstring save_status[] =
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(Revision 146125)
+++ gcc/fortran/decl.c	(Arbeitskopie)
@@ -4104,9 +4104,14 @@ add_hidden_procptr_result (gfc_symbol *s
     {
       gfc_symtree *stree;
       if (case1)
-        gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree);
+	gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree);
       else if (case2)
-        gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree);
+	{
+	  gfc_symtree *st2;
+	  gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree);
+	  st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
+	  st2->n.sym = stree->n.sym;
+	}
       sym->result = stree->n.sym;
 
       sym->result->attr.proc_pointer = sym->attr.proc_pointer;
@@ -4291,6 +4296,7 @@ got_ts:
 	    }
 	  sym->ts.interface = proc_if;
 	  sym->attr.untyped = 1;
+	  sym->attr.if_source = IFSRC_IFBODY;
 	}
       else if (current_ts.type != BT_UNKNOWN)
 	{
@@ -4300,6 +4306,7 @@ got_ts:
 	  sym->ts.interface->ts = current_ts;
 	  sym->ts.interface->attr.function = 1;
 	  sym->attr.function = sym->ts.interface->attr.function;
+	  sym->attr.if_source = IFSRC_UNKNOWN;
 	}
 
       if (gfc_match (" =>") == MATCH_YES)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(Revision 146125)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -274,9 +274,12 @@ typedef enum gfc_access
 gfc_access;
 
 /* Flags to keep track of where an interface came from.
-   4 elements = 2 bits.  */
+   3 elements = 2 bits.  */
 typedef enum ifsrc
-{ IFSRC_UNKNOWN = 0, IFSRC_DECL, IFSRC_IFBODY, IFSRC_USAGE
+{ IFSRC_UNKNOWN = 0,	/* Interface unknown, only return type may be known.  */
+  IFSRC_DECL,		/* FUNCTION or SUBROUTINE declaration.  */
+  IFSRC_IFBODY		/* INTERFACE statement or PROCEDURE statement
+			   with explicit interface.  */
 }
 ifsrc;
 
Index: gcc/fortran/trans-const.c
===================================================================
--- gcc/fortran/trans-const.c	(Revision 146125)
+++ gcc/fortran/trans-const.c	(Arbeitskopie)
@@ -176,7 +176,7 @@ gfc_conv_string_init (tree length, gfc_e
 void
 gfc_conv_const_charlen (gfc_charlen * cl)
 {
-  if (cl->backend_decl)
+  if (!cl || cl->backend_decl)
     return;
 
   if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(Revision 146125)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -3146,9 +3146,9 @@ gfc_check_pointer_assign (gfc_expr *lval
 	  gfc_error ("Abstract interface '%s' is invalid "
 		     "in procedure pointer assignment at %L",
 		     rvalue->symtree->name, &rvalue->where);
+	  return FAILURE;
 	}
       if (rvalue->expr_type == EXPR_VARIABLE
-	  && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
 	  && !gfc_compare_interfaces (lvalue->symtree->n.sym,
 				      rvalue->symtree->n.sym, 0))
 	{
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 146125)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -1129,6 +1129,30 @@ is_illegal_recursion (gfc_symbol* sym, g
 }
 
 
+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;
+    }
+  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.  */
 
@@ -1142,6 +1166,10 @@ resolve_procedure_expression (gfc_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;
@@ -2306,14 +2334,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))
     {
@@ -9181,6 +9203,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)
     {
@@ -9195,30 +9220,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;
+	  copy_formal_args (sym, ifc);
 
 	  sym->attr.allocatable = ifc->attr.allocatable;
 	  sym->attr.pointer = ifc->attr.pointer;
! { dg-do compile }
!
! PR 39735: procedure pointer assignments: return value is not checked
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

implicit none
procedure(real(4)), pointer :: p1
procedure(integer), pointer :: p2
procedure(sub), pointer :: p3
procedure(), pointer :: p4
procedure(real(8)),pointer :: p5
real(4), external, pointer :: p6

! valid
p2 => iabs
p3 => sub
p4 => p2
p6 => p1

! invalid
p1 => iabs   ! { dg-error "Interfaces don't match" }
p1 => p2     ! { dg-error "Interfaces don't match" }
p1 => p5     ! { dg-error "Interfaces don't match" }
p6 => iabs   ! { dg-error "Interfaces don't match" }

contains

  subroutine sub(i)
    integer :: i
  end subroutine

end


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]