2009-08-21 Janus Weil <janus@gcc.gnu.org>

	PR fortran/41106
	* primary.c (gfc_variable_attr): Make it work also on EXPR_FUNCTION.
	(gfc_expr_attr): Use gfc_variable_attr for procedure pointer components.
	* resolve.c (resolve_fl_derived): Handle CHARACTER-valued procedure
	pointer components.
	* trans-expr.c (gfc_conv_component_ref): Ditto.
	(gfc_conv_variable): Ditto.
	(gfc_conv_procedure_call): Ditto.
	(gfc_trans_pointer_assignment): Ditto.
	* trans-types.c (gfc_get_derived_type): Ditto.

2009-08-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41106
	* gfortran.dg/proc_ptr_23.f90: New.
	* gfortran.dg/proc_ptr_comp_15.f90: New.
	* gfortran.dg/proc_ptr_comp_16.f90: New.
	* gfortran.dg/proc_ptr_comp_17.f90: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150987 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6fde5a4..53a9d6d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2009-08-21  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41106
+       * primary.c (gfc_variable_attr): Make it work also on EXPR_FUNCTION.
+       (gfc_expr_attr): Use gfc_variable_attr for procedure pointer components.
+       * resolve.c (resolve_fl_derived): Handle CHARACTER-valued procedure
+       pointer components.
+       * trans-expr.c (gfc_conv_component_ref): Ditto.
+       (gfc_conv_variable): Ditto.
+       (gfc_conv_procedure_call): Ditto.
+       (gfc_trans_pointer_assignment): Ditto.
+       * trans-types.c (gfc_get_derived_type): Ditto.
+
 2009-08-20  Tobias Schlüter  <tobi@gcc.gnu.org>
 
        * trans-stmt.c (gfc_trans_do): Add a few missing folds.

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index e0021c5..0a917f7 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1938,7 +1938,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   symbol_attribute attr;
   gfc_ref *ref;
 
-  if (expr->expr_type != EXPR_VARIABLE)
+  if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
 
   ref = expr->ref;
@@ -2032,6 +2032,8 @@ gfc_expr_attr (gfc_expr *e)
 
       if (e->value.function.esym != NULL)
        attr = e->value.function.esym->result->attr;
+      else
+       attr = gfc_variable_attr (e, NULL);
 
       /* TODO: NULL() returns pointers.  May have to take care of this
         here.  */

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 3782bb2..411e2c8 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9476,7 +9476,7 @@ resolve_fl_derived (gfc_symbol *sym)
              if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
                {
                  c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
-                 /* TODO: gfc_expr_replace_symbols (c->ts.u.cl->length, c);*/
+                 gfc_expr_replace_comp (c->ts.u.cl->length, c);
                }
            }
          else if (c->ts.interface->name[0] != '\0')
@@ -9604,7 +9604,7 @@ resolve_fl_derived (gfc_symbol *sym)
          return FAILURE;
        }
 
-      if (c->ts.type == BT_CHARACTER)
+      if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
        {
         if (c->ts.u.cl->length == NULL
             || (resolve_charlen (c->ts.u.cl) == FAILURE)

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index c2c1f0f..3f5e76d 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -474,7 +474,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
 
   se->expr = tmp;
 
-  if (c->ts.type == BT_CHARACTER)
+  if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
     {
       tmp = c->ts.u.cl->backend_decl;
       /* Components must always be constant length.  */
@@ -714,7 +714,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
      separately.  */
   if (se->want_pointer)
     {
-      if (expr->ts.type == BT_CHARACTER)
+      if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
        gfc_conv_string_parameter (se);
       else 
        se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
@@ -2577,16 +2577,25 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
   gfc_init_block (&post);
   gfc_init_interface_mapping (&mapping);
-  need_interface_mapping = ((sym->ts.type == BT_CHARACTER
-                                 && sym->ts.u.cl->length
-                                 && sym->ts.u.cl->length->expr_type
-                                               != EXPR_CONSTANT)
-                             || (comp && comp->attr.dimension)
-                             || (!comp && sym->attr.dimension));
-  if (comp)
-    formal = comp->formal;
+  if (!comp)
+    {
+      formal = sym->formal;
+      need_interface_mapping = sym->attr.dimension ||
+                              (sym->ts.type == BT_CHARACTER
+                               && sym->ts.u.cl->length
+                               && sym->ts.u.cl->length->expr_type
+                                  != EXPR_CONSTANT);
+    }
   else
-    formal = sym->formal;
+    {
+      formal = comp->formal;
+      need_interface_mapping = comp->attr.dimension ||
+                              (comp->ts.type == BT_CHARACTER
+                               && comp->ts.u.cl->length
+                               && comp->ts.u.cl->length->expr_type
+                                  != EXPR_CONSTANT);
+    }
+
   /* Evaluate the arguments.  */
   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
     {
@@ -2913,12 +2922,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
     }
   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
 
-  ts = sym->ts;
+  if (comp)
+    ts = comp->ts;
+  else
+   ts = sym->ts;
+
   if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
     se->string_length = build_int_cst (gfc_charlen_type_node, 1);
   else if (ts.type == BT_CHARACTER)
     {
-      if (sym->ts.u.cl->length == NULL)
+      if (ts.u.cl->length == NULL)
        {
          /* Assumed character length results are not allowed by 5.1.1.5 of the
             standard and are trapped in resolve.c; except in the case of SPREAD
@@ -2943,9 +2956,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          /* Calculate the length of the returned string.  */
          gfc_init_se (&parmse, NULL);
          if (need_interface_mapping)
-           gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.u.cl->length);
+           gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
          else
-           gfc_conv_expr (&parmse, sym->ts.u.cl->length);
+           gfc_conv_expr (&parmse, ts.u.cl->length);
          gfc_add_block_to_block (&se->pre, &parmse.pre);
          gfc_add_block_to_block (&se->post, &parmse.post);
          
@@ -2963,7 +2976,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       len = cl.backend_decl;
     }
 
-  byref = (comp && comp->attr.dimension)
+  byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
          || (!comp && gfc_return_by_reference (sym));
   if (byref)
     {
@@ -3004,7 +3017,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          tmp = gfc_build_addr_expr (NULL_TREE, tmp);
          retargs = gfc_chainon_list (retargs, tmp);
        }
-      else if (sym->result->attr.dimension)
+      else if (!comp && sym->result->attr.dimension)
        {
          gcc_assert (se->loop && info);
 
@@ -3036,7 +3049,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
          /* Return an address to a char[0:len-1]* temporary for
             character pointers.  */
-         if (sym->attr.pointer || sym->attr.allocatable)
+         if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+              || (comp && (comp->attr.pointer || comp->attr.allocatable)))
            {
              var = gfc_create_var (type, "pstr");
 
@@ -3148,12 +3162,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              /* Bundle in the string length.  */
              se->string_length = len;
            }
-         else if (sym->ts.type == BT_CHARACTER)
+         else if (ts.type == BT_CHARACTER)
            {
              /* Dereference for character pointer results.  */
-             if (sym->attr.pointer || sym->attr.allocatable)
-               se->expr = build_fold_indirect_ref_loc (input_location,
-                                                   var);
+             if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+                 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
+               se->expr = build_fold_indirect_ref_loc (input_location, var);
              else
                se->expr = var;
 
@@ -3161,9 +3175,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
            }
          else
            {
-             gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
-             se->expr = build_fold_indirect_ref_loc (input_location,
-                                                 var);
+             gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+             se->expr = build_fold_indirect_ref_loc (input_location, var);
            }
        }
     }
@@ -4237,7 +4250,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 
       /* Check character lengths if character expression.  The test is only
         really added if -fbounds-check is enabled.  */
-      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
+         && !expr1->symtree->n.sym->attr.proc_pointer
+         && !gfc_is_proc_ptr_comp (expr1, NULL))
        {
          gcc_assert (expr2->ts.type == BT_CHARACTER);
          gcc_assert (lse.string_length && rse.string_length);

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 4a29399..454a155 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2134,12 +2134,11 @@ gfc_get_derived_type (gfc_symbol * derived)
                                                    PACKED_STATIC,
                                                    !c->attr.target);
        }
-      else if (c->attr.pointer)
+      else if (c->attr.pointer && !c->attr.proc_pointer)
        field_type = build_pointer_type (field_type);
 
       field = gfc_add_field_to_struct (&fieldlist, typenode,
-                                      get_identifier (c->name),
-                                      field_type);
+                                      get_identifier (c->name), field_type);
       if (c->loc.lb)
        gfc_set_decl_location (field, &c->loc);
       else if (derived->declared_at.lb)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 80b9cd8..0a31814 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2009-08-21  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41106
+       * gfortran.dg/proc_ptr_23.f90: New.
+       * gfortran.dg/proc_ptr_comp_15.f90: New.
+       * gfortran.dg/proc_ptr_comp_16.f90: New.
+       * gfortran.dg/proc_ptr_comp_17.f90: New.
+
 2009-08-21  Jakub Jelinek  <jakub@redhat.com>
 
        PR c++/41131

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_23.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_23.f90
new file mode 100644 (file)
index 0000000..ee94712
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_23.f90
@@ -0,0 +1,19 @@
+! { dg-do run }
+!
+! PR 41106: [F03] Procedure Pointers with CHARACTER results
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+character(len=5) :: str
+procedure(character(len=5)), pointer :: pp
+pp => abc
+print *,pp()
+str = pp()
+if (str/='abcde') call abort()
+contains
+ function abc()
+  character(len=5) :: abc
+  abc = 'abcde'
+ end function abc
+end
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_15.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_15.f90
new file mode 100644 (file)
index 0000000..9f15d14
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_15.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+!
+! PR 41106: [F03] Procedure Pointers with CHARACTER results
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+module m
+ type :: t
+ procedure(character(len=5)), pointer, nopass :: ptr
+ end type
+contains
+ function abc()
+  character(len=5) :: abc
+  abc = 'abcde'
+ end function abc
+end module m
+
+use m
+ type(t) :: x
+ character(len=5) :: str
+ x%ptr => abc
+ print *,x%ptr()
+ str = x%ptr()
+ if (str/='abcde') call abort()
+end
+
+! { dg-final { cleanup-modules "m" } }
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_16.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_16.f90
new file mode 100644 (file)
index 0000000..e6b77a2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_16.f90
@@ -0,0 +1,30 @@
+! { dg-do run }
+!
+! PR 41106: [F03] Procedure Pointers with CHARACTER results
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+ type :: t
+  procedure(abc), pointer, nopass :: ptr
+ end type
+contains
+ function abc(i)
+  integer :: i
+  character(len=i) :: abc
+  abc = 'abcde'
+ end function abc
+end module m
+
+use m
+ type(t) :: x
+ character(len=4) :: str
+ x%ptr => abc
+ print *,x%ptr(4)
+ if (x%ptr(4)/='abcd') call abort
+ str = x%ptr(3)
+ if (str/='abc') call abort()
+end
+
+! { dg-final { cleanup-modules "m" } }
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_17.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_17.f90
new file mode 100644 (file)
index 0000000..cfe498b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_17.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+!
+! PR 41106: [F03] Procedure Pointers with CHARACTER results
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+ type :: t
+ procedure(abc), pointer, nopass :: ptr
+ end type
+contains
+ function abc(arg)
+  character(len=5),pointer :: abc
+  character(len=5),target :: arg
+  abc => arg
+ end function abc
+end module m
+
+use m
+ type(t) :: x
+ character(len=5) :: str = 'abcde'
+ character(len=5), pointer :: strptr
+ x%ptr => abc
+ print *,x%ptr(str)
+ strptr => x%ptr(str)
+ if (strptr/='abcde') call abort()
+ str = 'fghij'
+ if (strptr/='fghij') call abort()
+end
+
+! { dg-final { cleanup-modules "m" } }
+