From: janus Date: Fri, 21 Aug 2009 09:43:04 +0000 (+0000) Subject: 2009-08-21 Janus Weil X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=1d84f30a09bc526c646dbbbef88787b991feca8f 2009-08-21 Janus Weil 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 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 6fde5a48b73..53a9d6d99ec 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2009-08-21 Janus Weil + + 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 * trans-stmt.c (gfc_trans_do): Add a few missing folds. diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index e0021c54b18..0a917f7f048 100644 --- 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 3782bb27e85..411e2c8d9dc 100644 --- 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 c2c1f0fbed4..3f5e76d137d 100644 --- 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 4a293998800..454a155c1d3 100644 --- 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 80b9cd846f7..0a3181446c4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2009-08-21 Janus Weil + + 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 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 index 00000000000..ee947122f2b --- /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 + +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 index 00000000000..9f15d14dbe4 --- /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 + +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 index 00000000000..e6b77a22f02 --- /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 + +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 index 00000000000..cfe498b0eca --- /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 + +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" } } +