[multiple changes]

2015-09-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40054
	PR fortran/63921
	* decl.c (get_proc_name): Return if statement function is
	found.
	* expr.c (gfc_check_vardef_context): Add error return for
	derived type expression lacking the derived type itself.
	* match.c (gfc_match_ptr_fcn_assign): New function.
	* match.h : Add prototype for gfc_match_ptr_fcn_assign.
	* parse.c : Add static flag 'in_specification_block'.
	(decode_statement): If in specification block match a statement
	function, then, if no error arising from statement function
	matching, try to match pointer function assignment.
	(parse_interface): Set 'in_specification_block' on exiting from
	parse_spec.
	(parse_spec): Set and then reset 'in_specification_block'.
	(gfc_parse_file): Set 'in_specification_block'.
	* resolve.c (get_temp_from_expr): Extend to include functions
	and array constructors as rvalues..
	(resolve_ptr_fcn_assign): New function.
	(gfc_resolve_code): Call it on finding a pointer function as an
	lvalue. If valid or on error, go back to start of resolve_code.
	* symbol.c (gfc_add_procedure): Add a sentence to the error to
	flag up the ambiguity between a statement function and pointer
	function assignment at the end of the specification block.

2015-09-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40054
	PR fortran/63921
	* gfortran.dg/fmt_tab_1.f90: Change from run to compile and set
	standard as legacy.
	* gfortran.dg/fmt_tab_2.f90: Add extra tab error.
	* gfortran.dg/function_types_3.f90: Change error message to
	"Type inaccessible...."
	* gfortran.dg/ptr_func_assign_1.f08: New test.
	* gfortran.dg/ptr_func_assign_2.f08: New test.

2015-09-25  Mikael Morin  <mikael.morin@sfr.fr>

	PR fortran/40054
	PR fortran/63921
	* gfortran.dg/ptr_func_assign_3.f08: New test.
	* gfortran.dg/ptr_func_assign_4.f08: New test.

From-SVN: r228222

16 files changed, 566 insertions, 39 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5159b8b..2830c91 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,30 @@
+2015-09-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40054
+	PR fortran/63921
+	* decl.c (get_proc_name): Return if statement function is
+	found.
+	* expr.c (gfc_check_vardef_context): Add error return for
+	derived type expression lacking the derived type itself.
+	* match.c (gfc_match_ptr_fcn_assign): New function.
+	* match.h : Add prototype for gfc_match_ptr_fcn_assign.
+	* parse.c : Add static flag 'in_specification_block'.
+	(decode_statement): If in specification block match a statement
+	function, then, if no error arising from statement function
+	matching, try to match pointer function assignment.
+	(parse_interface): Set 'in_specification_block' on exiting from
+	parse_spec.
+	(parse_spec): Set and then reset 'in_specification_block'.
+	(gfc_parse_file): Set 'in_specification_block'.
+	* resolve.c (get_temp_from_expr): Extend to include functions
+	and array constructors as rvalues..
+	(resolve_ptr_fcn_assign): New function.
+	(gfc_resolve_code): Call it on finding a pointer function as an
+	lvalue. If valid or on error, go back to start of resolve_code.
+	* symbol.c (gfc_add_procedure): Add a sentence to the error to
+	flag up the ambiguity between a statement function and pointer
+	function assignment at the end of the specification block.
+
 2015-09-28  Nathan Sidwell  <nathan@codesourcery.com>
 
 	* f95-lang.c (DEF_FUNCTION_TYPE_VAR_6): New.
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 6829d17..39c1136 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -901,6 +901,8 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
     return rc;
 
   sym = *result;
+  if (sym->attr.proc == PROC_ST_FUNCTION)
+    return rc;
 
   if (sym->attr.module_procedure
       && sym->attr.if_source == IFSRC_IFBODY)
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 3a0ef4d..9a27fa9 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4822,6 +4822,15 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
       return false;
     }
 
+  if (e->ts.type == BT_DERIVED
+      && e->ts.u.derived == NULL)
+    {
+      if (context)
+	gfc_error ("Type inaccessible in variable definition context (%s) "
+		   "at %L", context, &e->where);
+      return false;
+    }
+
   /* F2008, C1303.  */
   if (!alloc_obj
       && (attr.lock_comp
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 523e9b2..a50ec2d 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -4886,7 +4886,6 @@ match
 gfc_match_st_function (void)
 {
   gfc_error_buffer old_error;
-
   gfc_symbol *sym;
   gfc_expr *expr;
   match m;
@@ -4931,6 +4930,66 @@ undo_error:
 }
 
 
+/* Match an assignment to a pointer function (F2008). This could, in
+   general be ambiguous with a statement function. In this implementation
+   it remains so if it is the first statement after the specification
+   block.  */
+
+match
+gfc_match_ptr_fcn_assign (void)
+{
+  gfc_error_buffer old_error;
+  locus old_loc;
+  gfc_symbol *sym;
+  gfc_expr *expr;
+  match m;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  old_loc = gfc_current_locus;
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    return m;
+
+  gfc_find_symbol (name, NULL, 1, &sym);
+  if (sym && sym->attr.flavor != FL_PROCEDURE)
+    return MATCH_NO;
+
+  gfc_push_error (&old_error);
+
+  if (sym && sym->attr.function)
+    goto match_actual_arglist;
+
+  gfc_current_locus = old_loc;
+  m = gfc_match_symbol (&sym, 0);
+  if (m != MATCH_YES)
+    return m;
+
+  if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL))
+    goto undo_error;
+
+match_actual_arglist:
+  gfc_current_locus = old_loc;
+  m = gfc_match (" %e", &expr);
+  if (m != MATCH_YES)
+    goto undo_error;
+
+  new_st.op = EXEC_ASSIGN;
+  new_st.expr1 = expr;
+  expr = NULL;
+
+  m = gfc_match (" = %e%t", &expr);
+  if (m != MATCH_YES)
+    goto undo_error;
+
+  new_st.expr2 = expr;
+  return MATCH_YES;
+
+undo_error:
+  gfc_pop_error (&old_error);
+  return MATCH_NO;
+}
+
+
 /***************** SELECT CASE subroutines ******************/
 
 /* Free a single case structure.  */
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 91c9825..1b51a88 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -107,6 +107,7 @@ match gfc_match_namelist (void);
 match gfc_match_module (void);
 match gfc_match_equivalence (void);
 match gfc_match_st_function (void);
+match gfc_match_ptr_fcn_assign (void);
 match gfc_match_case (void);
 match gfc_match_select (void);
 match gfc_match_select_type (void);
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index f8d84de..6f3d24b 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -141,7 +141,7 @@ use_modules (void)
    for the specification statements in a function, whose
    characteristics are deferred into the specification statements.
    eg.:  INTEGER (king = mykind) foo ()
-	 USE mymodule, ONLY mykind..... 
+	 USE mymodule, ONLY mykind.....
    The KIND parameter needs a return after USE or IMPORT, whereas
    derived type declarations can occur anywhere, up the executable
    block.  ST_GET_FCN_CHARACTERISTICS is returned when we have run
@@ -287,6 +287,7 @@ end_of_block:
   return ST_GET_FCN_CHARACTERISTICS;
 }
 
+static bool in_specification_block;
 
 /* This is the primary 'decode_statement'.  */
 static gfc_statement
@@ -344,7 +345,7 @@ decode_statement (void)
 	return ST_FUNCTION;
       else if (m == MATCH_ERROR)
 	reject_statement ();
-      else 
+      else
 	gfc_undo_symbols ();
       gfc_current_locus = old_locus;
     }
@@ -356,7 +357,18 @@ decode_statement (void)
 
   match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
   match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
-  match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
+
+  if (in_specification_block)
+    {
+      m = match_word (NULL, gfc_match_st_function, &old_locus);
+      if (m == MATCH_YES)
+	return ST_STATEMENT_FUNCTION;
+    }
+
+  if (!(in_specification_block && m == MATCH_ERROR))
+    {
+      match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT);
+    }
 
   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
@@ -910,7 +922,7 @@ decode_gcc_attribute (void)
 
 /* Assert next length characters to be equal to token in free form.  */
 
-static void 
+static void
 verify_token_free (const char* token, int length, bool last_was_use_stmt)
 {
   int i;
@@ -1013,7 +1025,7 @@ next_free (void)
 	}
       else if (c == '$')
 	{
-	  /* Since both OpenMP and OpenACC directives starts with 
+	  /* Since both OpenMP and OpenACC directives starts with
 	     !$ character sequence, we must check all flags combinations */
 	  if ((flag_openmp || flag_openmp_simd)
 	      && !flag_openacc)
@@ -1044,9 +1056,9 @@ next_free (void)
 	      return decode_oacc_directive ();
 	    }
 	}
-      gcc_unreachable (); 
+      gcc_unreachable ();
     }
- 
+
   if (at_bol && c == ';')
     {
       if (!(gfc_option.allow_std & GFC_STD_F2008))
@@ -1132,7 +1144,7 @@ next_fixed (void)
 
 	case '*':
 	  c = gfc_next_char_literal (NONSTRING);
-	  
+
 	  if (TOLOWER (c) == 'g')
 	    {
 	      for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
@@ -1246,7 +1258,7 @@ blank_line:
   if (digit_flag)
     gfc_warning_now (0, "Ignoring statement label in empty statement at %L",
 		     &label_locus);
-    
+
   gfc_current_locus.lb->truncated = 0;
   gfc_advance_line ();
   return ST_NONE;
@@ -2168,8 +2180,8 @@ gfc_ascii_statement (gfc_statement st)
 
 
 /* Create a symbol for the main program and assign it to ns->proc_name.  */
- 
-static void 
+
+static void
 main_program_symbol (gfc_namespace *ns, const char *name)
 {
   gfc_symbol *main_program;
@@ -2708,7 +2720,7 @@ endType:
 	    }
 
 	  seen_sequence = 1;
-	  gfc_add_sequence (&gfc_current_block ()->attr, 
+	  gfc_add_sequence (&gfc_current_block ()->attr,
 			    gfc_current_block ()->name, NULL);
 	  break;
 
@@ -2771,7 +2783,7 @@ endType:
 	  coarray = true;
 	  sym->attr.coarray_comp = 1;
 	}
-     
+
       if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
 	  && !c->attr.pointer)
 	{
@@ -2851,7 +2863,7 @@ endType:
 
 
 /* Parse an ENUM.  */
- 
+
 static void
 parse_enum (void)
 {
@@ -2942,7 +2954,7 @@ loop:
 	  gfc_new_block->attr.pointer = 0;
 	  gfc_new_block->attr.proc_pointer = 1;
 	}
-      if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, 
+      if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
 				       gfc_new_block->formal, NULL))
 	{
 	  reject_statement ();
@@ -3008,6 +3020,7 @@ loop:
 decl:
   /* Read data declaration statements.  */
   st = parse_spec (ST_NONE);
+  in_specification_block = true;
 
   /* Since the interface block does not permit an IMPLICIT statement,
      the default type for the function or the result must be taken
@@ -3139,6 +3152,8 @@ parse_spec (gfc_statement st)
   bool bad_characteristic = false;
   gfc_typespec *ts;
 
+  in_specification_block = true;
+
   verify_st_order (&ss, ST_NONE, false);
   if (st == ST_NONE)
     st = next_statement ();
@@ -3199,14 +3214,14 @@ loop:
 
 	case ST_NONE:
 	  break;
-	  
+
 	default:
 	  gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
 		     gfc_ascii_statement (st));
 	  reject_statement ();
 	  break;
       }
-  
+
   /* If we find a statement that can not be followed by an IMPLICIT statement
      (and thus we can expect to see none any further), type the function result
      if it has not yet been typed.  Be careful not to give the END statement
@@ -3372,6 +3387,8 @@ declSt:
 	ts->type = BT_UNKNOWN;
     }
 
+  in_specification_block = false;
+
   return st;
 }
 
@@ -3768,7 +3785,7 @@ done:
    context that causes it to become redefined.  If the symbol is an
    iterator, we generate an error message and return nonzero.  */
 
-int 
+int
 gfc_check_do_variable (gfc_symtree *st)
 {
   gfc_state_data *s;
@@ -3783,7 +3800,7 @@ gfc_check_do_variable (gfc_symtree *st)
 
   return 0;
 }
-  
+
 
 /* Checks to see if the current statement label closes an enddo.
    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
@@ -3842,7 +3859,7 @@ parse_critical_block (void)
   gfc_state_data s, *sd;
   gfc_statement st;
 
-  for (sd = gfc_state_stack; sd; sd = sd->previous) 
+  for (sd = gfc_state_stack; sd; sd = sd->previous)
     if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
       gfc_error_now (is_oacc (sd)
 		     ? "CRITICAL block inside of OpenACC region at %C"
@@ -4356,7 +4373,7 @@ parse_oacc_structured_block (gfc_statement acc_st)
   gfc_code *cp, *np;
   gfc_state_data s, *sd;
 
-  for (sd = gfc_state_stack; sd; sd = sd->previous) 
+  for (sd = gfc_state_stack; sd; sd = sd->previous)
     if (sd->state == COMP_CRITICAL)
       gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
 
@@ -4415,7 +4432,7 @@ parse_oacc_loop (gfc_statement acc_st)
   gfc_code *cp, *np;
   gfc_state_data s, *sd;
 
-  for (sd = gfc_state_stack; sd; sd = sd->previous) 
+  for (sd = gfc_state_stack; sd; sd = sd->previous)
     if (sd->state == COMP_CRITICAL)
       gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
 
@@ -4971,8 +4988,8 @@ parse_contained (int module)
 			   "ambiguous", gfc_new_block->name);
 	      else
 		{
-		  if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, 
-					 sym->name, 
+		  if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
+					 sym->name,
 					 &gfc_new_block->declared_at))
 		    {
 		      if (st == ST_FUNCTION)
@@ -5173,11 +5190,11 @@ contains:
 done:
   gfc_current_ns->code = gfc_state_stack->head;
   if (gfc_state_stack->state == COMP_PROGRAM
-      || gfc_state_stack->state == COMP_MODULE 
-      || gfc_state_stack->state == COMP_SUBROUTINE 
+      || gfc_state_stack->state == COMP_MODULE
+      || gfc_state_stack->state == COMP_SUBROUTINE
       || gfc_state_stack->state == COMP_FUNCTION
       || gfc_state_stack->state == COMP_BLOCK)
-    gfc_current_ns->oacc_declare_clauses 
+    gfc_current_ns->oacc_declare_clauses
       = gfc_state_stack->ext.oacc_declare_clauses;
 }
 
@@ -5592,6 +5609,7 @@ gfc_parse_file (void)
   if (gfc_at_eof ())
     goto done;
 
+  in_specification_block = true;
 loop:
   gfc_init_2 ();
   st = next_statement ();
@@ -5718,7 +5736,7 @@ prog_units:
   /* Do the resolution.  */
   resolve_all_program_units (gfc_global_ns_list);
 
-  /* Do the parse tree dump.  */ 
+  /* Do the parse tree dump.  */
   gfc_current_ns
 	= flag_dump_fortran_original ? gfc_global_ns_list : NULL;
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6ae086a..5822cb0 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9735,12 +9735,10 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
   ref = NULL;
   aref = NULL;
 
-  /* This function could be expanded to support other expression type
-     but this is not needed here.  */
-  gcc_assert (e->expr_type == EXPR_VARIABLE);
-
   /* Obtain the arrayspec for the temporary.  */
-  if (e->rank)
+   if (e->rank && e->expr_type != EXPR_ARRAY
+       && e->expr_type != EXPR_FUNCTION
+       && e->expr_type != EXPR_OP)
     {
       aref = gfc_find_array_ref (e);
       if (e->expr_type == EXPR_VARIABLE
@@ -9772,6 +9770,16 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
       if (as->type == AS_DEFERRED)
 	tmp->n.sym->attr.allocatable = 1;
     }
+  else if (e->rank && (e->expr_type == EXPR_ARRAY
+		       || e->expr_type == EXPR_FUNCTION
+		       || e->expr_type == EXPR_OP))
+    {
+      tmp->n.sym->as = gfc_get_array_spec ();
+      tmp->n.sym->as->type = AS_DEFERRED;
+      tmp->n.sym->as->rank = e->rank;
+      tmp->n.sym->attr.allocatable = 1;
+      tmp->n.sym->attr.dimension = 1;
+    }
   else
     tmp->n.sym->attr.dimension = 0;
 
@@ -10133,6 +10141,66 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
 }
 
 
+/* F2008: Pointer function assignments are of the form:
+	ptr_fcn (args) = expr
+   This function breaks these assignments into two statements:
+	temporary_pointer => ptr_fcn(args)
+	temporary_pointer = expr  */
+
+static bool
+resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
+{
+  gfc_expr *tmp_ptr_expr;
+  gfc_code *this_code;
+  gfc_component *comp;
+  gfc_symbol *s;
+
+  if ((*code)->expr1->expr_type != EXPR_FUNCTION)
+    return false;
+
+  /* Even if standard does not support this feature, continue to build
+     the two statements to avoid upsetting frontend_passes.c.  */
+  gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
+		  "%L", &(*code)->loc);
+
+  comp = gfc_get_proc_ptr_comp ((*code)->expr1);
+
+  if (comp)
+    s = comp->ts.interface;
+  else
+    s = (*code)->expr1->symtree->n.sym;
+
+  if (s == NULL || !s->result->attr.pointer)
+    {
+      gfc_error ("The function result on the lhs of the assignment at "
+		 "%L must have the pointer attribute.",
+		 &(*code)->expr1->where);
+      (*code)->op = EXEC_NOP;
+      return false;
+    }
+
+  tmp_ptr_expr = get_temp_from_expr ((*code)->expr2, ns);
+
+  /* get_temp_from_expression is set up for ordinary assignments. To that
+     end, where array bounds are not known, arrays are made allocatable.
+     Change the temporary to a pointer here.  */
+  tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
+  tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
+  tmp_ptr_expr->where = (*code)->loc;
+
+  this_code = build_assignment (EXEC_ASSIGN,
+				tmp_ptr_expr, (*code)->expr2,
+				NULL, NULL, (*code)->loc);
+  this_code->next = (*code)->next;
+  (*code)->next = this_code;
+  (*code)->op = EXEC_POINTER_ASSIGN;
+  (*code)->expr2 = (*code)->expr1;
+  (*code)->expr1 = tmp_ptr_expr;
+
+  return true;
+}
+
+
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -10228,7 +10296,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
 	  if (omp_workshare_save != -1)
 	    omp_workshare_flag = omp_workshare_save;
 	}
-
+start:
       t = true;
       if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
 	t = gfc_resolve_expr (code->expr1);
@@ -10318,6 +10386,14 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
 	      && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
 	    remove_caf_get_intrinsic (code->expr1);
 
+	  /* If this is a pointer function in an lvalue variable context,
+	     the new code will have to be resolved afresh. This is also the
+	     case with an error, where the code is transformed into NOP to
+	     prevent ICEs downstream.  */
+	  if (resolve_ptr_fcn_assign (&code, ns)
+	      || code->op == EXEC_NOP)
+	    goto start;
+
 	  if (!gfc_check_vardef_context (code->expr1, false, false, false,
 					 _("assignment")))
 	    break;
@@ -10332,6 +10408,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
 
 	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
 	  if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
+	      && code->expr1->ts.u.derived
 	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
 	    generate_component_assignments (&code, ns);
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 0f33608..35a3496 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -1541,9 +1541,19 @@ gfc_add_procedure (symbol_attribute *attr, procedure_type t,
 
   if (attr->proc != PROC_UNKNOWN && !attr->module_procedure)
     {
-      gfc_error ("%s procedure at %L is already declared as %s procedure",
+      if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL
+	  && !gfc_notification_std (GFC_STD_F2008))
+	gfc_error ("%s procedure at %L is already declared as %s "
+		   "procedure. \nF2008: A pointer function assignment "
+		   "is ambiguous if it is the first executable statement "
+		   "after the specification block. Please add any other "
+		   "kind of executable statement before it. FIXME",
 		 gfc_code2string (procedures, t), where,
 		 gfc_code2string (procedures, attr->proc));
+      else
+	gfc_error ("%s procedure at %L is already declared as %s "
+		   "procedure", gfc_code2string (procedures, t), where,
+		   gfc_code2string (procedures, attr->proc));
 
       return false;
     }
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index da9954d..db28ecf 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,22 @@
+2015-09-28  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40054
+	PR fortran/63921
+	* gfortran.dg/fmt_tab_1.f90: Change from run to compile and set
+	standard as legacy.
+	* gfortran.dg/fmt_tab_2.f90: Add extra tab error.
+	* gfortran.dg/function_types_3.f90: Change error message to
+	"Type inaccessible...."
+	* gfortran.dg/ptr_func_assign_1.f08: New test.
+	* gfortran.dg/ptr_func_assign_2.f08: New test.
+
+2015-09-25  Mikael Morin  <mikael.morin@sfr.fr>
+
+	PR fortran/40054
+	PR fortran/63921
+	* gfortran.dg/ptr_func_assign_3.f08: New test.
+	* gfortran.dg/ptr_func_assign_4.f08: New test.
+
 2015-09-28  Aditya Kumar  <aditya.k7@samsung.com>
 	    Sebastian Pop  <s.pop@samsung.com>
 
diff --git a/gcc/testsuite/gfortran.dg/fmt_tab_1.f90 b/gcc/testsuite/gfortran.dg/fmt_tab_1.f90
index cd95da2..f58e388 100644
--- a/gcc/testsuite/gfortran.dg/fmt_tab_1.f90
+++ b/gcc/testsuite/gfortran.dg/fmt_tab_1.f90
@@ -1,4 +1,5 @@
-! { dg-do run }
+! { dg-do compile }
+! { dg-options -Wno-error=tabs }
 ! PR fortran/32987
       program TestFormat
         write (*, 10)
diff --git a/gcc/testsuite/gfortran.dg/fmt_tab_2.f90 b/gcc/testsuite/gfortran.dg/fmt_tab_2.f90
index 17acf86..560d886 100644
--- a/gcc/testsuite/gfortran.dg/fmt_tab_2.f90
+++ b/gcc/testsuite/gfortran.dg/fmt_tab_2.f90
@@ -3,5 +3,5 @@
 ! PR fortran/32987
       program TestFormat
         write (*, 10) ! { dg-error "FORMAT label 10 at .1. not defined" }
- 10     format ('Hello ',	'bug!') ! { dg-error "Extension: Tab character in format" }
+ 10     format ('Hello ',	'bug!') ! { dg-error "Extension: Tab character in format|Nonconforming tab character" }
       end
diff --git a/gcc/testsuite/gfortran.dg/function_types_3.f90 b/gcc/testsuite/gfortran.dg/function_types_3.f90
index e834725..9ec4793 100644
--- a/gcc/testsuite/gfortran.dg/function_types_3.f90
+++ b/gcc/testsuite/gfortran.dg/function_types_3.f90
@@ -15,5 +15,5 @@ end
 ! PR 50403: SIGSEGV in gfc_use_derived
 
 type(f) function f()  ! { dg-error "Type name 'f' at .1. conflicts with previously declared entity|The type for function 'f' at .1. is not accessible" }
-  f=110               ! { dg-error "Unclassifiable statement" }
+  f=110               ! { dg-error "Type inaccessible in variable definition context" }
 end
diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08 b/gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08
new file mode 100644
index 0000000..58efb81
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08
@@ -0,0 +1,112 @@
+! { dg-do run }
+!
+! Tests implementation of F2008 feature: pointer function assignments.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module fcn_bar
+contains
+  function bar (arg, idx) result (res)
+    integer, pointer :: res
+    integer, target :: arg(:)
+    integer :: idx
+    res => arg (idx)
+    res = 99
+  end function
+end module
+
+module fcn_mydt
+  type mydt
+    integer, allocatable, dimension (:) :: i
+  contains
+    procedure, pass :: create
+    procedure, pass :: delete
+    procedure, pass :: fill
+    procedure, pass :: elem_fill
+  end type
+contains
+  subroutine create (this, sz)
+    class(mydt) :: this
+    integer :: sz
+    if (allocated (this%i)) deallocate (this%i)
+    allocate (this%i(sz))
+    this%i = 0
+  end subroutine
+  subroutine delete (this)
+    class(mydt) :: this
+    if (allocated (this%i)) deallocate (this%i)
+  end subroutine
+  function fill (this, idx) result (res)
+    integer, pointer :: res(:)
+    integer :: lb, ub
+    class(mydt), target :: this
+    integer :: idx
+    lb = idx
+    ub = lb + size(this%i) - 1
+    res => this%i(lb:ub)
+  end function
+  function elem_fill (this, idx) result (res)
+    integer, pointer :: res
+    class(mydt), target :: this
+    integer :: idx
+    res => this%i(idx)
+  end function
+end module
+
+  use fcn_bar
+  use fcn_mydt
+  integer, target :: a(3) = [1,2,3]
+  integer, pointer :: b
+  integer :: foobar, z, i, ifill(4) = [2, 7, 19, 61], ifill2(2) = [1,2]
+  type(mydt) :: dt
+  foobar (z) = z**2 ! { dg-warning "Obsolescent feature: Statement function" }
+  if (any (a .ne. [1,2,3])) call abort
+
+! Assignment to pointer result is after procedure call.
+  foo (a) = 77
+
+! Assignment within procedure applies.
+  b => foo (a)
+  if (b .ne. 99) call abort
+
+! Use of index for assignment.
+  bar (a, 2) = 99
+  if (any (a .ne. [99,99,3])) call abort
+
+! Make sure that statement function still works!
+  if (foobar (10) .ne. 100) call abort
+
+  bar (a, 3) = foobar (9)
+  if (any (a .ne. [99,99,81])) call abort
+
+! Try typebound procedure
+  call dt%create (6)
+  dt%elem_fill (3) = 42
+  if (dt%i(3) .ne. 42) call abort
+  dt%elem_fill (3) = 42 + dt%elem_fill (3) ! PR63921 style assignment
+  if (dt%i(3) .ne. 84) call abort
+  dt%elem_fill (3) = dt%elem_fill (3) - dt%elem_fill (3)
+  if (dt%i(3) .ne. 0) call abort
+! Array is now reset
+  dt%fill (3) = ifill                      ! Check with array variable rhs
+  dt%fill (1) = [2,1]                      ! Check with array constructor rhs
+  if (any (dt%i .ne. [2,1,ifill])) call abort
+  dt%fill (1) = footoo (size (dt%i, 1))    ! Check with array function rhs
+  if (any (dt%i .ne. [6,5,4,3,2,1])) call abort
+  dt%fill (3) = ifill + dt%fill (3)        ! Array version of PR63921 assignment
+  if (any (dt%i .ne. [6,5,6,10,21,62])) call abort
+  call dt%delete
+
+contains
+  function foo (arg)
+    integer, pointer :: foo
+    integer, target :: arg(:)
+    foo => arg (1)
+    foo = 99
+  end function
+  function footoo (arg) result(res)
+    integer :: arg
+    integer :: res(arg)
+    res = [(arg - i, i = 0, arg - 1)]
+  end function
+end
diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08 b/gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08
new file mode 100644
index 0000000..bb84b21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08
@@ -0,0 +1,113 @@
+! { dg-do compile }
+! { dg-options -std=f2003 }
+!
+! Is a copy of ptr_func_assign_1.f08 with checks for F2008 standard.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module fcn_bar
+contains
+  function bar (arg, idx) result (res)
+    integer, pointer :: res
+    integer, target :: arg(:)
+    integer :: idx
+    res => arg (idx)
+    res = 99
+  end function
+end module
+
+module fcn_mydt
+  type mydt
+    integer, allocatable, dimension (:) :: i
+  contains
+    procedure, pass :: create
+    procedure, pass :: delete
+    procedure, pass :: fill
+    procedure, pass :: elem_fill
+  end type
+contains
+  subroutine create (this, sz)
+    class(mydt) :: this
+    integer :: sz
+    if (allocated (this%i)) deallocate (this%i)
+    allocate (this%i(sz))
+    this%i = 0
+  end subroutine
+  subroutine delete (this)
+    class(mydt) :: this
+    if (allocated (this%i)) deallocate (this%i)
+  end subroutine
+  function fill (this, idx) result (res)
+    integer, pointer :: res(:)
+    integer :: lb, ub
+    class(mydt), target :: this
+    integer :: idx
+    lb = idx
+    ub = lb + size(this%i) - 1
+    res => this%i(lb:ub)
+  end function
+  function elem_fill (this, idx) result (res)
+    integer, pointer :: res
+    class(mydt), target :: this
+    integer :: idx
+    res => this%i(idx)
+  end function
+end module
+
+  use fcn_bar
+  use fcn_mydt
+  integer, target :: a(3) = [1,2,3]
+  integer, pointer :: b
+  integer :: foobar, z, i, ifill(4) = [2, 7, 19, 61], ifill2(2) = [1,2]
+  type(mydt) :: dt
+  foobar (z) = z**2 ! { dg-warning "Obsolescent feature: Statement function" }
+  if (any (a .ne. [1,2,3])) call abort
+
+! Assignment to pointer result is after procedure call.
+  foo (a) = 77 ! { dg-error "Pointer procedure assignment" }
+
+! Assignment within procedure applies.
+  b => foo (a)
+  if (b .ne. 99) call abort
+
+! Use of index for assignment.
+  bar (a, 2) = 99 ! { dg-error "Pointer procedure assignment" }
+  if (any (a .ne. [99,99,3])) call abort
+
+! Make sure that statement function still works!
+  if (foobar (10) .ne. 100) call abort
+
+  bar (a, 3) = foobar (9)! { dg-error "Pointer procedure assignment" }
+  if (any (a .ne. [99,99,81])) call abort
+
+! Try typebound procedure
+  call dt%create (6)
+  dt%elem_fill (3) = 42 ! { dg-error "Pointer procedure assignment" }
+  if (dt%i(3) .ne. 42) call abort
+  dt%elem_fill (3) = 42 + dt%elem_fill (3)! { dg-error "Pointer procedure assignment" }
+  if (dt%i(3) .ne. 84) call abort
+  dt%elem_fill (3) = dt%elem_fill (3) - dt%elem_fill (3)! { dg-error "Pointer procedure assignment" }
+  if (dt%i(3) .ne. 0) call abort
+! Array is now reset
+  dt%fill (3) = ifill ! { dg-error "Pointer procedure assignment" }
+  dt%fill (1) = [2,1] ! { dg-error "Pointer procedure assignment" }
+  if (any (dt%i .ne. [2,1,ifill])) call abort
+  dt%fill (1) = footoo (size (dt%i, 1)) ! { dg-error "Pointer procedure assignment" }
+  if (any (dt%i .ne. [6,5,4,3,2,1])) call abort
+  dt%fill (3) = ifill + dt%fill (3) ! { dg-error "Pointer procedure assignment" }
+  if (any (dt%i .ne. [6,5,6,10,21,62])) call abort
+  call dt%delete
+
+contains
+  function foo (arg)
+    integer, pointer :: foo
+    integer, target :: arg(:)
+    foo => arg (1)
+    foo = 99
+  end function
+  function footoo (arg) result(res)
+    integer :: arg
+    integer :: res(arg)
+    res = [(arg - i, i = 0, arg - 1)]
+  end function
+end
diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08 b/gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08
new file mode 100644
index 0000000..4d56afb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08
@@ -0,0 +1,52 @@
+! { dg-do run }
+!
+! Tests corrections to implementation of pointer function assignments.
+!
+! Contributed by Mikael Morin  <mikael.morin@sfr.fr>
+!
+module m
+  implicit none
+  type dt
+    integer :: data
+  contains
+    procedure assign_dt
+    generic :: assignment(=) => assign_dt
+  end type
+contains
+  subroutine assign_dt(too, from)
+    class(dt), intent(out) :: too
+    type(dt), intent(in) :: from
+    too%data = from%data + 1
+  end subroutine
+end module m
+
+program p
+  use m
+  integer, parameter :: b = 3
+  integer, target    :: a = 2
+  type(dt), target :: tdt
+  type(dt) :: sdt = dt(1)
+
+  func (arg=b) = 1         ! This was rejected as an unclassifiable statement
+  if (a /= 1) call abort
+
+  func (b + b - 3) = -1
+  if (a /= -1) call abort
+
+  dtfunc () = sdt          ! Check that defined assignment is resolved
+  if (tdt%data /= 2) call abort
+contains
+  function func(arg) result(r)
+    integer, pointer :: r
+    integer :: arg
+    if (arg == 3) then
+      r => a
+    else
+      r => null()
+    end if
+  end function func
+  function dtfunc() result (r)
+    type(dt), pointer :: r
+    r => tdt
+  end function
+end program p
diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 b/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08
new file mode 100644
index 0000000..46ef2ac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08
@@ -0,0 +1,27 @@
+! { dg-do compile }
+!
+! Tests correction to implementation of pointer function assignments.
+!
+! Contributed by Mikael Morin  <mikael.morin@sfr.fr>
+!
+program p
+  integer, target :: a(3) = 2
+  integer :: b(3, 3) = 1
+  integer :: c
+
+  c = 3
+  func (b(2, 2)) = b ! { dg-error "Different ranks" }
+  func (c) = b       ! { dg-error "Different ranks" }
+
+contains
+  function func(arg) result(r)
+    integer, pointer :: r(:)
+    integer :: arg
+
+    if (arg == 1) then
+      r => a
+    else
+      r => null()
+    end if
+  end function func
+end program p