2009-07-09 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk rev 149427



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@149430 138bc75d-0d04-0410-961f-82ee72b054a4

17 files changed, 304 insertions, 82 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6b66cbd89be..5b1ed772829 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,62 @@
+2008-07-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40629
+	* resolve.c (check_host_association):  Use the existing
+	accessible symtree and treat function expressions with
+	symbols that have procedure flavor.
+
+2009-07-09  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40646
+	* dump-parse-tree.c (show_expr): Renamed 'is_proc_ptr_comp'.
+	* expr.c (is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'.
+	(gfc_check_pointer_assign): Renamed 'is_proc_ptr_comp'.
+	(replace_comp,gfc_expr_replace_comp): New functions, analogous
+	to 'replace_symbol' and 'gfc_expr_replace_symbol', just with components
+	instead of symbols.
+	* gfortran.h (gfc_expr_replace_comp): New prototype.
+	(is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'.
+	* interface.c (compare_actual_formal): Renamed 'is_proc_ptr_comp'.
+	* match.c (gfc_match_pointer_assignment): Ditto.
+	* primary.c (gfc_match_varspec): Handle array-valued procedure pointers
+	and procedure pointer components. Renamed 'is_proc_ptr_comp'.
+	* resolve.c (resolve_fl_derived): Correctly handle interfaces with
+	RESULT statement, and handle array-valued procedure pointer components.
+	(resolve_actual_arglist,resolve_ppc_call,resolve_expr_ppc): Renamed
+	'is_proc_ptr_comp'.
+	* trans-array.c (gfc_walk_function_expr): Ditto.
+	* trans-decl.c (gfc_get_symbol_decl): Security check for presence of
+	ns->proc_name.
+	* trans-expr.c (gfc_conv_procedure_call): Handle array-valued procedure
+	pointer components. Renamed 'is_proc_ptr_comp'.
+	(conv_function_val,gfc_trans_arrayfunc_assign): Renamed
+	'is_proc_ptr_comp'.
+	(gfc_get_proc_ptr_comp): Do not modify the argument 'e', but instead
+	make a copy of it.
+	* trans-io.c (gfc_trans_transfer): Handle array-valued procedure
+	pointer components.
+
+2009-07-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40604
+	* intrinsic.c (gfc_convert_type_warn): Set sym->result.
+	* trans-expr.c (gfc_conv_procedure_call): Fix -fcheck=pointer
+	for optional arguments.
+
+2009-07-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40675
+	* simplify.c (gfc_simplify_sign): Handle signed zero correctly.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sign): Support
+	-fno-sign-zero.
+	* invoke.texi (-fno-sign-zero): Add text regarding SIGN intrinsic.
+
+2008-07-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40591
+	* decl.c (match_procedure_interface):  Correct the association
+	or creation of the interface procedure's symbol.
+
 2009-07-04  Jakub Jelinek  <jakub@redhat.com>
 
 	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): For integer
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index c3760a81c0b..e2816348643 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4156,9 +4156,12 @@ static match
 match_procedure_interface (gfc_symbol **proc_if)
 {
   match m;
+  gfc_symtree *st;
   locus old_loc, entry_loc;
-  old_loc = entry_loc = gfc_current_locus;
+  gfc_namespace *old_ns = gfc_current_ns;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
 
+  old_loc = entry_loc = gfc_current_locus;
   gfc_clear_ts (&current_ts);
 
   if (gfc_match (" (") != MATCH_YES)
@@ -4177,13 +4180,25 @@ match_procedure_interface (gfc_symbol **proc_if)
   if (m == MATCH_ERROR)
     return m;
 
+  /* Procedure interface is itself a procedure.  */
   gfc_current_locus = old_loc;
+  m = gfc_match_name (name);
 
-  /* Get the name of the procedure or abstract interface
-  to inherit the interface from.  */
-  m = gfc_match_symbol (proc_if, 1);
-  if (m != MATCH_YES)
-    return m;
+  /* First look to see if it is already accessible in the current
+     namespace because it is use associated or contained.  */
+  st = NULL;
+  if (gfc_find_sym_tree (name, NULL, 0, &st))
+    return MATCH_ERROR;
+
+  /* If it is still not found, then try the parent namespace, if it
+     exists and create the symbol there if it is still not found.  */
+  if (gfc_current_ns->parent)
+    gfc_current_ns = gfc_current_ns->parent;
+  if (st == NULL && gfc_get_ha_sym_tree (name, &st))
+    return MATCH_ERROR;
+
+  gfc_current_ns = old_ns;
+  *proc_if = st->n.sym;
 
   /* Various interface checks.  */
   if (*proc_if)
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index cfd8a7d9d04..2a411d48ad7 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -544,7 +544,7 @@ show_expr (gfc_expr *p)
       if (p->value.function.name == NULL)
 	{
 	  fprintf (dumpfile, "%s", p->symtree->n.sym->name);
-	  if (is_proc_ptr_comp (p, NULL))
+	  if (gfc_is_proc_ptr_comp (p, NULL))
 	    show_ref (p->ref);
 	  fputc ('[', dumpfile);
 	  show_actual_arglist (p->value.function.actual);
@@ -553,7 +553,7 @@ show_expr (gfc_expr *p)
       else
 	{
 	  fprintf (dumpfile, "%s", p->value.function.name);
-	  if (is_proc_ptr_comp (p, NULL))
+	  if (gfc_is_proc_ptr_comp (p, NULL))
 	    show_ref (p->ref);
 	  fputc ('[', dumpfile);
 	  fputc ('[', dumpfile);
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index b1d572ec231..a8f9f6a213e 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3213,7 +3213,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	}
 
       /* TODO: Enable interface check for PPCs.  */
-      if (is_proc_ptr_comp (rvalue, NULL))
+      if (gfc_is_proc_ptr_comp (rvalue, NULL))
 	return SUCCESS;
       if ((rvalue->expr_type == EXPR_VARIABLE
 	   && !gfc_compare_interfaces (lvalue->symtree->n.sym,
@@ -3558,7 +3558,7 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr)
    provided).  */
 
 bool
-is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
 {
   gfc_ref *ref;
   bool ppc = false;
@@ -3672,3 +3672,39 @@ gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
 {
   gfc_traverse_expr (expr, dest, &replace_symbol, 0);
 }
+
+/* The following is analogous to 'replace_symbol', and needed for copying
+   interfaces for procedure pointer components. The argument 'sym' must formally
+   be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
+   However, it gets actually passed a gfc_component (i.e. the procedure pointer
+   component in whose formal_ns the arguments have to be).  */
+
+static bool
+replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+  gfc_component *comp;
+  comp = (gfc_component *)sym;
+  if ((expr->expr_type == EXPR_VARIABLE 
+       || (expr->expr_type == EXPR_FUNCTION
+	   && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
+      && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
+    {
+      gfc_symtree *stree;
+      gfc_namespace *ns = comp->formal_ns;
+      /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+	 the symtree rather than create a new one (and probably fail later).  */
+      stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+		      		expr->symtree->n.sym->name);
+      gcc_assert (stree);
+      stree->n.sym->attr = expr->symtree->n.sym->attr;
+      expr->symtree = stree;
+    }
+  return false;
+}
+
+void
+gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
+{
+  gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
+}
+
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 260d718b13c..5e3f80fa822 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2539,8 +2539,9 @@ bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
 void gfc_expr_set_symbols_referenced (gfc_expr *);
 gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
 void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
+void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
 
-bool is_proc_ptr_comp (gfc_expr *, gfc_component **);
+bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
 
 /* st.c */
 extern gfc_code new_st;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index ca500f582d9..cedca457f0c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1915,7 +1915,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 		&& a->expr->symtree->n.sym->attr.proc_pointer)
 	       || (a->expr->expr_type == EXPR_FUNCTION
 		   && a->expr->symtree->n.sym->result->attr.proc_pointer)
-	       || is_proc_ptr_comp (a->expr, NULL)))
+	       || gfc_is_proc_ptr_comp (a->expr, NULL)))
 	{
 	  if (where)
 	    gfc_error ("Expected a procedure pointer for argument '%s' at %L",
@@ -1925,7 +1925,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
 	 provided for a procedure formal argument.  */
-      if (a->expr->ts.type != BT_PROCEDURE && !is_proc_ptr_comp (a->expr, NULL)
+      if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && f->sym->attr.flavor == FL_PROCEDURE)
 	{
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 7bb10ec245b..9402234b034 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -3994,6 +3994,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
   new_expr->shape = gfc_copy_shape (shape, rank);
 
   gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
+  new_expr->symtree->n.sym->result = new_expr->symtree->n.sym;
   new_expr->symtree->n.sym->ts = *ts;
   new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
   new_expr->symtree->n.sym->attr.function = 1;
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 5d0448f3cbe..68cc0128eed 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -1024,9 +1024,12 @@ really useful for use by the gfortran testsuite.
 
 @item -fsign-zero
 @opindex @code{fsign-zero}
-When writing zero values, show the negative sign if the sign bit is set.
-@code{fno-sign-zero} does not print the negative sign of zero values for
-compatibility with F77.  Default behavior is to show the negative sign.
+When enabled, floating point numbers of value zero with the sign bit set
+are written as negative number in formatted output and treated as
+negative in the @code{SIGN} intrinsic.  @code{fno-sign-zero} does not
+print the negative sign of zero values and regards zero as positive
+number in the @code{SIGN} intrinsic for compatibility with F77.
+Default behavior is to show the negative sign.
 @end table
 
 @node Code Gen Options
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 1cc6e5fdfa2..9de4da25b7b 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1337,7 +1337,7 @@ gfc_match_pointer_assignment (void)
     }
 
   if (lvalue->symtree->n.sym->attr.proc_pointer
-      || is_proc_ptr_comp (lvalue, NULL))
+      || gfc_is_proc_ptr_comp (lvalue, NULL))
     gfc_matching_procptr_assignment = 1;
 
   m = gfc_match (" %e%t", &rvalue);
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index cc6cada545c..4a84aedbc30 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1727,7 +1727,10 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 
   gfc_gobble_whitespace ();
   if ((equiv_flag && gfc_peek_ascii_char () == '(')
-      || (sym->attr.dimension && !sym->attr.proc_pointer))
+      || (sym->attr.dimension && !sym->attr.proc_pointer
+	  && !gfc_is_proc_ptr_comp (primary, NULL)
+	  && !(gfc_matching_procptr_assignment
+	       && sym->attr.flavor == FL_PROCEDURE)))
     {
       /* In EQUIVALENCE, we don't know yet whether we are seeing
 	 an array, character variable or array of character
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 41ac03796bf..9b091ad0162 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1236,7 +1236,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	  continue;
 	}
 
-      if (is_proc_ptr_comp (e, &comp))
+      if (gfc_is_proc_ptr_comp (e, &comp))
 	{
 	  e->ts = comp->ts;
 	  e->expr_type = EXPR_VARIABLE;
@@ -4402,12 +4402,13 @@ check_host_association (gfc_expr *e)
 	      gfc_free (e->shape);
 	    }
 
-	  /* Give the symbol a symtree in the right place!  */
-	  gfc_get_sym_tree (sym->name, gfc_current_ns, &st, false);
-	  st->n.sym = sym;
+	  /* Give the expression the right symtree!  */
+	  gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
+	  gcc_assert (st != NULL);
 
-	  if (old_sym->attr.flavor == FL_PROCEDURE)
-	    {
+	  if (old_sym->attr.flavor == FL_PROCEDURE
+		|| e->expr_type == EXPR_FUNCTION)
+  	    {
 	      /* Original was function so point to the new symbol, since
 		 the actual argument list is already attached to the
 		 expression. */
@@ -4834,7 +4835,7 @@ static gfc_try
 resolve_ppc_call (gfc_code* c)
 {
   gfc_component *comp;
-  gcc_assert (is_proc_ptr_comp (c->expr1, &comp));
+  gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp));
 
   c->resolved_sym = c->expr1->symtree->n.sym;
   c->expr1->expr_type = EXPR_VARIABLE;
@@ -4862,7 +4863,7 @@ static gfc_try
 resolve_expr_ppc (gfc_expr* e)
 {
   gfc_component *comp;
-  gcc_assert (is_proc_ptr_comp (e, &comp));
+  gcc_assert (gfc_is_proc_ptr_comp (e, &comp));
 
   /* Convert to EXPR_FUNCTION.  */
   e->expr_type = EXPR_FUNCTION;
@@ -9034,32 +9035,40 @@ resolve_fl_derived (gfc_symbol *sym)
 		resolve_intrinsic (ifc, &ifc->declared_at);
 
 	      if (ifc->result)
-		c->ts = ifc->result->ts;
-	      else   
-		c->ts = ifc->ts;
+		{
+		  c->ts = ifc->result->ts;
+		  c->attr.allocatable = ifc->result->attr.allocatable;
+		  c->attr.pointer = ifc->result->attr.pointer;
+		  c->attr.dimension = ifc->result->attr.dimension;
+		  c->as = gfc_copy_array_spec (ifc->result->as);
+		}
+	      else
+		{   
+		  c->ts = ifc->ts;
+		  c->attr.allocatable = ifc->attr.allocatable;
+		  c->attr.pointer = ifc->attr.pointer;
+		  c->attr.dimension = ifc->attr.dimension;
+		  c->as = gfc_copy_array_spec (ifc->as);
+		}
 	      c->ts.interface = ifc;
 	      c->attr.function = ifc->attr.function;
 	      c->attr.subroutine = ifc->attr.subroutine;
 	      gfc_copy_formal_args_ppc (c, ifc);
 
-	      c->attr.allocatable = ifc->attr.allocatable;
-	      c->attr.pointer = ifc->attr.pointer;
 	      c->attr.pure = ifc->attr.pure;
 	      c->attr.elemental = ifc->attr.elemental;
-	      c->attr.dimension = ifc->attr.dimension;
 	      c->attr.recursive = ifc->attr.recursive;
 	      c->attr.always_explicit = ifc->attr.always_explicit;
-	      /* Copy array spec.  */
-	      c->as = gfc_copy_array_spec (ifc->as);
-	      /* TODO: if (c->as)
+	      /* Replace symbols in array spec.  */
+	      if (c->as)
 		{
 		  int i;
 		  for (i = 0; i < c->as->rank; i++)
 		    {
-		      gfc_expr_replace_symbols (c->as->lower[i], c);
-		      gfc_expr_replace_symbols (c->as->upper[i], c);
+		      gfc_expr_replace_comp (c->as->lower[i], c);
+		      gfc_expr_replace_comp (c->as->upper[i], c);
 		    }
-	        }*/
+	        }
 	      /* Copy char length.  */
 	      if (ifc->ts.cl)
 		{
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index f57f68e3e68..c619f14be1e 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -4957,16 +4957,15 @@ gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
       mpz_abs (result->value.integer, x->value.integer);
       if (mpz_sgn (y->value.integer) < 0)
 	mpz_neg (result->value.integer, result->value.integer);
-
       break;
 
     case BT_REAL:
-      /* TODO: Handle -0.0 and +0.0 correctly on machines that support
-	 it.  */
-      mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
-      if (mpfr_sgn (y->value.real) < 0)
-	mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
-
+      if (gfc_option.flag_sign_zero)
+	mpfr_copysign (result->value.real, x->value.real, y->value.real,
+		       GFC_RND_MODE);
+      else
+	mpfr_setsign (result->value.real, x->value.real,
+		      mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
       break;
 
     default:
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 4b832cf8832..32858a7abcd 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6366,7 +6366,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
       sym = expr->symtree->n.sym;
 
   /* A function that returns arrays.  */
-  is_proc_ptr_comp (expr, &comp);
+  gfc_is_proc_ptr_comp (expr, &comp);
   if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
       || (comp && comp->attr.dimension))
     {
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index d64c3fae3c9..0d6dc6de975 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1015,7 +1015,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 		|| sym->attr.use_assoc
 		|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
 
-  if (sym->ns && sym->ns->proc_name->attr.function)
+  if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
     byref = gfc_return_by_reference (sym->ns->proc_name);
   else
     byref = 0;
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index d4ee169d08e..b6a825a8125 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1492,7 +1492,7 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
 {
   tree tmp;
 
-  if (is_proc_ptr_comp (expr, NULL))
+  if (gfc_is_proc_ptr_comp (expr, NULL))
     tmp = gfc_get_proc_ptr_comp (se, expr);
   else if (sym->attr.dummy)
     {
@@ -2463,14 +2463,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	  gfc_init_se (&fptrse, NULL);
 	  if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
-	      || is_proc_ptr_comp (arg->next->expr, NULL))
+	      || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
 	    fptrse.want_pointer = 1;
 
 	  gfc_conv_expr (&fptrse, arg->next->expr);
 	  gfc_add_block_to_block (&se->pre, &fptrse.pre);
 	  gfc_add_block_to_block (&se->post, &fptrse.post);
 
-	  if (is_proc_ptr_comp (arg->next->expr, NULL))
+	  if (gfc_is_proc_ptr_comp (arg->next->expr, NULL))
 	    tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
 	  else
 	    tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
@@ -2526,7 +2526,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  return 0;
 	}
     }
-  
+
+  gfc_is_proc_ptr_comp (expr, &comp);
+
   if (se->ss != NULL)
     {
       if (!sym->attr.elemental)
@@ -2534,8 +2536,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  gcc_assert (se->ss->type == GFC_SS_FUNCTION);
           if (se->ss->useflags)
             {
-              gcc_assert (gfc_return_by_reference (sym)
-                      && sym->result->attr.dimension);
+	      gcc_assert ((!comp && gfc_return_by_reference (sym)
+			   && sym->result->attr.dimension)
+			  || (comp && comp->attr.dimension));
               gcc_assert (se->loop != NULL);
 
               /* Access the previously obtained result.  */
@@ -2551,7 +2554,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
   gfc_init_block (&post);
   gfc_init_interface_mapping (&mapping);
-  is_proc_ptr_comp (expr, &comp);
   need_interface_mapping = ((sym->ts.type == BT_CHARACTER
 				  && sym->ts.cl->length
 				  && sym->ts.cl->length->expr_type
@@ -2784,37 +2786,86 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       /* Add argument checking of passing an unallocated/NULL actual to
          a nonallocatable/nonpointer dummy.  */
 
-      if (gfc_option.rtcheck & GFC_RTCHECK_POINTER)
+      if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
         {
-	  gfc_symbol *sym;
+	  symbol_attribute *attr;
 	  char *msg;
 	  tree cond;
 
 	  if (e->expr_type == EXPR_VARIABLE)
-	    sym = e->symtree->n.sym;
+	    attr = &e->symtree->n.sym->attr;
 	  else if (e->expr_type == EXPR_FUNCTION)
-	    sym = e->symtree->n.sym->result;
-	  else
-	    goto end_pointer_check;
+	    {
+	      /* For intrinsic functions, the gfc_attr are not available.  */
+	      if (e->symtree->n.sym->attr.generic && e->value.function.isym)
+		goto end_pointer_check;
 
-	  if (sym->attr.allocatable
-	      && (fsym == NULL || !fsym->attr.allocatable))
-	    asprintf (&msg, "Allocatable actual argument '%s' is not "
-		      "allocated", sym->name);
-	  else if (sym->attr.pointer
-	      && (fsym == NULL || !fsym->attr.pointer))
-	    asprintf (&msg, "Pointer actual argument '%s' is not "
-		      "associated", sym->name);
-          else if (sym->attr.proc_pointer
-	      && (fsym == NULL || !fsym->attr.proc_pointer))
-	    asprintf (&msg, "Proc-pointer actual argument '%s' is not "
-		      "associated", sym->name);
+	      if (e->symtree->n.sym->attr.generic)
+		attr = &e->value.function.esym->attr;
+	      else
+		attr = &e->symtree->n.sym->result->attr;
+	    }
 	  else
 	    goto end_pointer_check;
 
-	  cond  = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
-			       fold_convert (TREE_TYPE (parmse.expr),
-					     null_pointer_node));
+          if (attr->optional)
+	    {
+              /* If the actual argument is an optional pointer/allocatable and
+		 the formal argument takes an nonpointer optional value,
+		 it is invalid to pass a non-present argument on, even
+		 though there is no technical reason for this in gfortran.
+		 See Fortran 2003, Section 12.4.1.6 item (7)+(8).  */
+	      tree present, nullptr, type;
+
+	      if (attr->allocatable
+		  && (fsym == NULL || !fsym->attr.allocatable))
+		asprintf (&msg, "Allocatable actual argument '%s' is not "
+			  "allocated or not present", e->symtree->n.sym->name);
+	      else if (attr->pointer
+		       && (fsym == NULL || !fsym->attr.pointer))
+		asprintf (&msg, "Pointer actual argument '%s' is not "
+			  "associated or not present",
+			  e->symtree->n.sym->name);
+	      else if (attr->proc_pointer
+		       && (fsym == NULL || !fsym->attr.proc_pointer))
+		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
+			  "associated or not present",
+			  e->symtree->n.sym->name);
+	      else
+		goto end_pointer_check;
+
+	      present = gfc_conv_expr_present (e->symtree->n.sym);
+	      type = TREE_TYPE (present);
+	      present = fold_build2 (EQ_EXPR, boolean_type_node, present,
+				     fold_convert (type, null_pointer_node));
+	      type = TREE_TYPE (parmse.expr);
+	      nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
+				     fold_convert (type, null_pointer_node));
+	      cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
+				  present, nullptr);
+	    }
+          else
+	    {
+	      if (attr->allocatable
+		  && (fsym == NULL || !fsym->attr.allocatable))
+		asprintf (&msg, "Allocatable actual argument '%s' is not "
+		      "allocated", e->symtree->n.sym->name);
+	      else if (attr->pointer
+		       && (fsym == NULL || !fsym->attr.pointer))
+		asprintf (&msg, "Pointer actual argument '%s' is not "
+		      "associated", e->symtree->n.sym->name);
+	      else if (attr->proc_pointer
+		       && (fsym == NULL || !fsym->attr.proc_pointer))
+		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
+		      "associated", e->symtree->n.sym->name);
+	      else
+		goto end_pointer_check;
+
+
+	      cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
+				  fold_convert (TREE_TYPE (parmse.expr),
+						null_pointer_node));
+	    }
  
 	  gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
 				   msg);
@@ -2898,6 +2949,30 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	  retargs = gfc_chainon_list (retargs, se->expr);
 	}
+      else if (comp && comp->attr.dimension)
+	{
+	  gcc_assert (se->loop && info);
+
+	  /* Set the type of the array.  */
+	  tmp = gfc_typenode_for_spec (&comp->ts);
+	  info->dimen = se->loop->dimen;
+
+	  /* Evaluate the bounds of the result, if known.  */
+	  gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
+
+	  /* Create a temporary to store the result.  In case the function
+	     returns a pointer, the temporary will be a shallow copy and
+	     mustn't be deallocated.  */
+	  callee_alloc = comp->attr.allocatable || comp->attr.pointer;
+	  gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
+				       NULL_TREE, false, !comp->attr.pointer,
+				       callee_alloc, &se->ss->expr->where);
+
+	  /* Pass the temporary as the first argument.  */
+	  tmp = info->descriptor;
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	  retargs = gfc_chainon_list (retargs, tmp);
+	}
       else if (sym->result->attr.dimension)
 	{
 	  gcc_assert (se->loop && info);
@@ -2997,7 +3072,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
         x = f()
      where f is pointer valued, we have to dereference the result.  */
   if (!se->want_pointer && !byref && sym->attr.pointer
-      && !is_proc_ptr_comp (expr, NULL))
+      && !gfc_is_proc_ptr_comp (expr, NULL))
     se->expr = build_fold_indirect_ref (se->expr);
 
   /* f2c calling conventions require a scalar default real function to
@@ -3025,7 +3100,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
       if (!se->direct_byref)
 	{
-	  if (sym->attr.dimension)
+	  if (sym->attr.dimension || (comp && comp->attr.dimension))
 	    {
 	      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
 		{
@@ -3382,9 +3457,11 @@ tree
 gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
 {
   gfc_se comp_se;
+  gfc_expr *e2;
   gfc_init_se (&comp_se, NULL);
-  e->expr_type = EXPR_VARIABLE;
-  gfc_conv_expr (&comp_se, e);
+  e2 = gfc_copy_expr (e);
+  e2->expr_type = EXPR_VARIABLE;
+  gfc_conv_expr (&comp_se, e2);
   comp_se.expr = build_fold_addr_expr (comp_se.expr);
   return gfc_evaluate_now (comp_se.expr, &se->pre);  
 }
@@ -4417,7 +4494,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
      functions.  */
   gcc_assert (expr2->value.function.isym
-	      || (is_proc_ptr_comp (expr2, &comp)
+	      || (gfc_is_proc_ptr_comp (expr2, &comp)
 		  && comp && comp->attr.dimension)
 	      || (!comp && gfc_return_by_reference (expr2->value.function.esym)
 		  && expr2->value.function.esym->result->attr.dimension));
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index dd3b3cdff7b..89b98ec7279 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1263,22 +1263,41 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
   gfc_conv_intrinsic_function_args (se, expr, args, 2);
   if (expr->ts.type == BT_REAL)
     {
+      tree abs;
+
       switch (expr->ts.kind)
 	{
 	case 4:
 	  tmp = built_in_decls[BUILT_IN_COPYSIGNF];
+	  abs = built_in_decls[BUILT_IN_FABSF];
 	  break;
 	case 8:
 	  tmp = built_in_decls[BUILT_IN_COPYSIGN];
+	  abs = built_in_decls[BUILT_IN_FABS];
 	  break;
 	case 10:
 	case 16:
 	  tmp = built_in_decls[BUILT_IN_COPYSIGNL];
+	  abs = built_in_decls[BUILT_IN_FABSL];
 	  break;
 	default:
 	  gcc_unreachable ();
 	}
-      se->expr = build_call_expr (tmp, 2, args[0], args[1]);
+
+      /* We explicitly have to ignore the minus sign. We do so by using
+	 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1).  */
+      if (!gfc_option.flag_sign_zero
+	  && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
+	{
+	  tree cond, zero;
+	  zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
+	  cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
+	  se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
+				  build_call_expr (abs, 1, args[0]),
+				  build_call_expr (tmp, 2, args[0], args[1]));
+	}
+      else
+	se->expr = build_call_expr (tmp, 2, args[0], args[1]);
       return;
     }
 
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index f8b943d7c0b..5263a67b754 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -2165,7 +2165,7 @@ gfc_trans_transfer (gfc_code * code)
       /* Transfer an array. If it is an array of an intrinsic
 	 type, pass the descriptor to the library.  Otherwise
 	 scalarize the transfer.  */
-      if (expr->ref)
+      if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
 	{
 	  for (ref = expr->ref; ref && ref->type != REF_ARRAY;
 		 ref = ref->next);