This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Other format: | [Raw text] |
Hi all, here is another patch concerning procedure pointers and procedure pointer components, fixing the cases where those have CHARACTER return values. Since character return values are a bit of a special case (being returned by reference etc), quite a number of adjustments had to be made for PPCs, mostly in gfc_conv_procedure_call. One of the test cases was found by Tobias when reviewing my patch for PR 40870, and I added a few more (e.g. with non-constant character-lengths or character-pointer return values). Regtested on x86_64-unknown-linux-gnu. Ok for trunk? Cheers, Janus 2009-08-20 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 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.
Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (revision 150962) +++ gcc/fortran/trans-expr.c (working copy) @@ -474,7 +474,7 @@ gfc_conv_component_ref (gfc_se * se, gfc 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 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); @@ -2913,12 +2913,16 @@ gfc_conv_procedure_call (gfc_se * se, gf } 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 +2947,9 @@ gfc_conv_procedure_call (gfc_se * se, gf /* 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 +2967,7 @@ gfc_conv_procedure_call (gfc_se * se, gf 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 +3008,7 @@ gfc_conv_procedure_call (gfc_se * se, gf 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 +3040,8 @@ gfc_conv_procedure_call (gfc_se * se, gf /* 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 +3153,12 @@ gfc_conv_procedure_call (gfc_se * se, gf /* 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 +3166,8 @@ gfc_conv_procedure_call (gfc_se * se, gf } 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 +4241,9 @@ gfc_trans_pointer_assignment (gfc_expr * /* 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); Index: gcc/fortran/trans-types.c =================================================================== --- gcc/fortran/trans-types.c (revision 150962) +++ gcc/fortran/trans-types.c (working copy) @@ -2134,12 +2134,11 @@ gfc_get_derived_type (gfc_symbol * deriv 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) Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 150962) +++ gcc/fortran/resolve.c (working copy) @@ -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) Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (revision 150962) +++ gcc/fortran/primary.c (working copy) @@ -1938,7 +1938,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_t 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. */
Attachment:
proc_ptr_23.f90
Description: Binary data
Attachment:
proc_ptr_comp_15.f90
Description: Binary data
Attachment:
proc_ptr_comp_16.f90
Description: Binary data
Attachment:
proc_ptr_comp_17.f90
Description: Binary data
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |