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

gcc/fortran/ChangeLog

+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-21  Joseph Myers  <joseph@codesourcery.com>
 
 	* ChangeLog, ChangeLog-2002, ChangeLog-2003, ChangeLog-2004,

gcc/fortran/decl.c

@@ -4104,9 +4104,14 @@ add_hidden_procptr_result (gfc_symbol *sym)
     {
       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)

gcc/fortran/expr.c

@@ -3146,9 +3146,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	  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))
 	{

gcc/fortran/gfortran.h

@@ -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;
 
@@ -2370,8 +2373,8 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
 
-void copy_formal_args (gfc_symbol *, gfc_symbol *);
-void copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
+void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
+void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
 
 void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
 

gcc/fortran/interface.c

@@ -479,8 +479,6 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
 }
 
 
-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_symbol *s2, int generic_flag)
 {
   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))
+  if ((s1->attr.function && !s2->attr.function)
+      || (s1->attr.subroutine && s2->attr.function))
     return 0;
-  if (count_types_test (f2, f1))
-    return 0;
-
-  if (generic_flag)
-    {
-      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 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 (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;
-}
 
+  f1 = s1->formal;
+  f2 = s2->formal;
 
-/* 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;
-
-  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_actual_arglist **ap, locus *where)
     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;

gcc/fortran/intrinsic.c

@@ -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,

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;

gcc/fortran/symbol.c

@@ -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[] =
@@ -3768,6 +3767,7 @@ gen_shape_param (gfc_formal_arglist **head,
   add_formal_arg (head, tail, formal_arg, param_sym);
 }
 
+
 /* Add a procedure interface to the given symbol (i.e., store a
    reference to the list of formal arguments).  */
 
@@ -3780,6 +3780,7 @@ add_proc_interface (gfc_symbol *sym, ifsrc source,
   sym->attr.if_source = source;
 }
 
+
 /* Copy the formal args from an existing symbol, src, into a new
    symbol, dest.  New formal args are created, and the description of
    each arg is set according to the existing ones.  This function is
@@ -3788,7 +3789,7 @@ add_proc_interface (gfc_symbol *sym, ifsrc source,
    args based on the args of a given named interface.  */
 
 void
-copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
+gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
 {
   gfc_formal_arglist *head = NULL;
   gfc_formal_arglist *tail = NULL;
@@ -3812,7 +3813,7 @@ copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
       formal_arg->sym->attr = curr_arg->sym->attr;
       formal_arg->sym->ts = curr_arg->sym->ts;
       formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
-      copy_formal_args (formal_arg->sym, curr_arg->sym);
+      gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
 
       /* If this isn't the first arg, set up the next ptr.  For the
         last arg built, the formal_arg->next will never get set to
@@ -3839,8 +3840,9 @@ copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
   gfc_current_ns = parent_ns;
 }
 
+
 void
-copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
+gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
 {
   gfc_formal_arglist *head = NULL;
   gfc_formal_arglist *tail = NULL;
@@ -3863,9 +3865,6 @@ copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
       /* May need to copy more info for the symbol.  */
       formal_arg->sym->ts = curr_arg->ts;
       formal_arg->sym->attr.optional = curr_arg->optional;
-      /*formal_arg->sym->attr = curr_arg->sym->attr;
-      formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
-      copy_formal_args (formal_arg->sym, curr_arg->sym);*/
 
       /* If this isn't the first arg, set up the next ptr.  For the
         last arg built, the formal_arg->next will never get set to
@@ -3892,6 +3891,7 @@ copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
   gfc_current_ns = parent_ns;
 }
 
+
 /* Builds the parameter list for the iso_c_binding procedure
    c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
    generic version of either the c_f_pointer or c_f_procpointer

gcc/fortran/trans-const.c

@@ -176,7 +176,7 @@ gfc_conv_string_init (tree length, gfc_expr * expr)
 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)

gcc/testsuite/ChangeLog

+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.
+
 2009-04-21  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
 
 	PR c++/35711

gcc/testsuite/gfortran.dg/assumed_charlen_function_5.f90

@@ -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)  ! { dg-warning "is obsolescent in fortran 95
   integer :: i
   print *, charr(i)
   test = 1
-end function test
\ No newline at end of file
+end function test
+

gcc/testsuite/gfortran.dg/external_initializer.f90

 ! { 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

gcc/testsuite/gfortran.dg/interface_26.f90

@@ -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 ) 

gcc/testsuite/gfortran.dg/intrinsic_subroutine.f90

@@ -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

gcc/testsuite/gfortran.dg/proc_ptr_15.f90

+! { 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
+

gcc/testsuite/gfortran.dg/proc_ptr_3.f90

@@ -27,7 +27,7 @@ interface
   end subroutine sp
 end interface
 
-external :: e1
+real, external :: e1
 
 interface
   subroutine e2(a,b)

gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90

@@ -8,6 +8,7 @@ module mo
 contains
 
   function j()
+    implicit none
     procedure(),pointer :: j
     intrinsic iabs
     j => iabs