From 8d60cc468e8c1956cef570588d4297ce3a740328 Mon Sep 17 00:00:00 2001 From: pault Date: Mon, 29 Jun 2009 20:38:59 +0000 Subject: 2009-06-29 Paul Thomas PR fortran/40551 * dependency.h : Add second bool* argument to prototype of gfc_full_array_ref_p. * dependency.c (gfc_full_array_ref_p): If second argument is present, return true if last dimension of reference is an element or has unity stride. * trans-array.c : Add NULL second argument to references to gfc_full_array_ref_p. * trans-expr.c : The same, except for; (gfc_trans_arrayfunc_assign): Return fail if lhs reference is not a full array or a contiguous section. 2009-06-29 Paul Thomas PR fortran/40551 * gfortran.dg/func_assign_2.f90 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149062 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index f79ad4b3cc7..6a38f10f656 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4300,6 +4300,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_ss *ss; gfc_ref * ref; bool seen_array_ref; + bool c = false; gfc_component *comp = NULL; /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ @@ -4311,6 +4312,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) && expr2->value.function.esym->attr.elemental) return NULL; + /* Fail if rhs is not FULL or a contiguous section. */ + if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c)) + return NULL; + /* Fail if EXPR1 can't be expressed as a descriptor. */ if (gfc_ref_needs_temporary_p (expr1->ref)) return NULL; @@ -4785,7 +4790,7 @@ copyable_array_p (gfc_expr * expr) if (expr->rank < 1 || !expr->ref || expr->ref->next) return false; - if (!gfc_full_array_ref_p (expr->ref)) + if (!gfc_full_array_ref_p (expr->ref, NULL)) return false; /* Next check that it's of a simple enough type. */ -- cgit v1.2.1 From 91cf6ba3f39e8d8ae45283cb3af328c1583eeb75 Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 29 Jun 2009 21:02:17 +0000 Subject: 2009-06-29 Tobias Burnus PR fortran/40580 * trans-expr.c (gfc_conv_procedure_call): Add -fcheck=pointer * check. * libgfortran.h: Add GFC_RTCHECK_POINTER. * invoke.texi (-fcheck): Document new pointer option. * options.c (gfc_handle_runtime_check_option): Handle pointer * option. * gfortran.texi (C Binding): Improve wording. * iso-c-binding.def: Remove obsolete comment. 2009-06-29 Tobias Burnus PR fortran/40580 * pointer_check_1.f90: New test. * pointer_check_2.f90: New test. * pointer_check_3.f90: New test. * pointer_check_4.f90: New test. * pointer_check_5.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149063 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6a38f10f656..19ac1390f82 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2772,6 +2772,48 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_add_expr_to_block (&se->post, tmp); } + /* Add argument checking of passing an unallocated/NULL actual to + a nonallocatable/nonpointer dummy. */ + + if (gfc_option.rtcheck & GFC_RTCHECK_POINTER) + { + gfc_symbol *sym; + char *msg; + tree cond; + + if (e->expr_type == EXPR_VARIABLE) + sym = e->symtree->n.sym; + else if (e->expr_type == EXPR_FUNCTION) + sym = e->symtree->n.sym->result; + else + 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); + 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); + gfc_free (msg); + } + end_pointer_check: + + /* Character strings are passed as two parameters, a length and a pointer - except for Bind(c) which only passes the pointer. */ if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c) -- cgit v1.2.1 From eee4a6d85d3a9f24b48a26fe6455807c53bad76b Mon Sep 17 00:00:00 2001 From: janus Date: Sat, 4 Jul 2009 12:28:43 +0000 Subject: 2009-07-04 Janus Weil PR fortran/40593 * interface.c (compare_actual_formal): Take care of proc-pointer-valued functions as actual arguments. * trans-expr.c (gfc_conv_procedure_call): Ditto. * resolve.c (resolve_specific_f0): Use the correct ts. 2009-07-04 Janus Weil PR fortran/40593 * gfortran.dg/proc_ptr_result_6.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149227 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 19ac1390f82..e872f22f900 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2640,6 +2640,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&parmse, e); parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } + else if (e->expr_type == EXPR_FUNCTION + && e->symtree->n.sym->result + && e->symtree->n.sym->result->attr.proc_pointer) + { + /* Functions returning procedure pointers. */ + gfc_conv_expr (&parmse, e); + if (fsym && fsym->attr.proc_pointer) + parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); + } else { gfc_conv_expr_reference (&parmse, e); -- cgit v1.2.1 From 88a37d69d9f4acebdb312422aca037999d333638 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 5 Jul 2009 19:13:59 +0000 Subject: 2009-07-05 Paul Thomas and Tobias Burnus PR fortran/40646 * gfortran.h : Change the compcall member of the 'value' union in the gfc_expr structure so that its fields overlap with the 'function' member. * resolve.c (resolve_compcall): Set the function.esym. * trans-expr.c (gfc_trans_arrayfunc_assign): Use is_proc_ptr_comp in the condition. * dependency.c (gfc_full_array_ref_p): Ensure that 'contiguous' retunrs a value if non-NULL. 2009-07-05 Paul Thomas and Tobias Burnus PR fortran/40646 * gfortran.dg/func_assign_3.f90 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149262 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e872f22f900..d4ee169d08e 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4416,11 +4416,11 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic functions. */ - is_proc_ptr_comp(expr2, &comp); gcc_assert (expr2->value.function.isym - || (comp && comp->attr.dimension) + || (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)); + && expr2->value.function.esym->result->attr.dimension)); ss = gfc_walk_expr (expr1); gcc_assert (ss != gfc_ss_terminator); -- cgit v1.2.1 From 40474135d8d7cc3275852d7ed5200e1993c362ad Mon Sep 17 00:00:00 2001 From: burnus Date: Thu, 9 Jul 2009 09:42:34 +0000 Subject: 2009-07-09 Tobias Burnus 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-09 Tobias Burnus PR fortran/40604 * gfortran.dg/pointer_check_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149405 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 91 +++++++++++++++++++++++++++++++++++++----------- 1 file changed, 70 insertions(+), 21 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d4ee169d08e..fe33286a402 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2784,37 +2784,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); -- cgit v1.2.1 From ff70e44325c390560120b8ab5a8e0043d0403aef Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 9 Jul 2009 14:07:03 +0000 Subject: 2009-07-09 Janus Weil 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 Janus Weil PR fortran/40646 * gfortran.dg/proc_ptr_22.f90: New. * gfortran.dg/proc_ptr_comp_12.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149419 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 52 +++++++++++++++++++++++++++++++++++++----------- 1 file changed, 40 insertions(+), 12 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index fe33286a402..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 @@ -2947,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); @@ -3046,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 @@ -3074,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) { @@ -3431,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); } @@ -4466,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)); -- cgit v1.2.1 From 452a374337164f940ddae97b6e8632bf34475e7f Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 13 Jul 2009 13:41:37 +0000 Subject: 2009-07-13 Janus Weil PR fortran/40646 * module.c (mio_symbol): If the symbol has formal arguments, the formal namespace will be present. * resolve.c (resolve_actual_arglist): Correctly handle 'called' procedure pointer components as actual arguments. (resolve_fl_derived,resolve_symbol): Make sure the formal namespace is present. * trans-expr.c (gfc_conv_procedure_call): Correctly handle the formal arguments of procedure pointer components. 2009-07-13 Janus Weil PR fortran/40646 * gfortran.dg/proc_ptr_22.f90: Extended. * gfortran.dg/proc_ptr_comp_12.f90: Extended. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149586 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b6a825a8125..787251d7627 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2560,7 +2560,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, != EXPR_CONSTANT) || (comp && comp->attr.dimension) || (!comp && sym->attr.dimension)); - formal = sym->formal; + if (comp) + formal = comp->formal; + else + formal = sym->formal; /* Evaluate the arguments. */ for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) { -- cgit v1.2.1 From 389dd41bd043170e7dc7660304f14a5f16af3562 Mon Sep 17 00:00:00 2001 From: manu Date: Thu, 16 Jul 2009 22:29:52 +0000 Subject: =?UTF-8?q?2009-07-17=20=20Aldy=20Hernandez=20=20=20=09=20=20=20=20Manuel=20L=C3=B3pez-Ib=C3=A1=C3=B1ez=20=20?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit PR 40435 * tree-complex.c, tree-loop-distribution.c, tree.c, tree.h, builtins.c, fold-const.c, omp-low.c, cgraphunit.c, tree-ssa-ccp.c, tree-ssa-dom.c, gimple-low.c, expr.c, tree-ssa-ifcombine.c, c-decl.c, stor-layout.c, tree-if-conv.c, c-typeck.c, gimplify.c, calls.c, tree-sra.c, tree-mudflap.c, tree-ssa-copy.c, tree-ssa-forwprop.c, c-convert.c, c-omp.c, varasm.c, tree-inline.c, c-common.c, c-common.h, gimple.c, tree-switch-conversion.c, gimple.h, tree-cfg.c, c-parser.c, convert.c: Add location argument to fold_{unary,binary,ternary}, fold_build[123], build_call_expr, build_size_arg, build_fold_addr_expr, build_call_array, non_lvalue, size_diffop, fold_build1_initializer, fold_build2_initializer, fold_build3_initializer, fold_build_call_array, fold_build_call_array_initializer, fold_single_bit_test, omit_one_operand, omit_two_operands, invert_truthvalue, fold_truth_not_expr, build_fold_indirect_ref, fold_indirect_ref, combine_comparisons, fold_builtin_*, fold_call_expr, build_range_check, maybe_fold_offset_to_address, round_up, round_down. objc/ * objc-act.c: Add location argument to all calls to build_fold_addr_expr. testsuite/ * gcc.dg/pr36902.c: Add column info. * g++.dg/gcov/gcov-2.C: Change count for definition. cp/ * typeck.c, init.c, class.c, method.c, rtti.c, except.c, error.c, tree.c, cp-gimplify.c, cxx-pretty-print.c, pt.c, semantics.c, call.c, cvt.c, mangle.c: Add location argument to fold_{unary,binary,ternary}, fold_build[123], build_call_expr, build_size_arg, build_fold_addr_expr, build_call_array, non_lvalue, size_diffop, fold_build1_initializer, fold_build2_initializer, fold_build3_initializer, fold_build_call_array, fold_build_call_array_initializer, fold_single_bit_test, omit_one_operand, omit_two_operands, invert_truthvalue, fold_truth_not_expr, build_fold_indirect_ref, fold_indirect_ref, combine_comparisons, fold_builtin_*, fold_call_expr, build_range_check, maybe_fold_offset_to_address, round_up, round_down. fortran/ * trans-expr.c, trans-array.c, trans-openmp.c, trans-stmt.c, trans.c, trans-io.c, trans-decl.c, trans-intrinsic.c: Add location argument to fold_{unary,binary,ternary}, fold_build[123], build_call_expr, build_size_arg, build_fold_addr_expr, build_call_array, non_lvalue, size_diffop, fold_build1_initializer, fold_build2_initializer, fold_build3_initializer, fold_build_call_array, fold_build_call_array_initializer, fold_single_bit_test, omit_one_operand, omit_two_operands, invert_truthvalue, fold_truth_not_expr, build_fold_indirect_ref, fold_indirect_ref, combine_comparisons, fold_builtin_*, fold_call_expr, build_range_check, maybe_fold_offset_to_address, round_up, round_down. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149722 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 95 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 63 insertions(+), 32 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 787251d7627..03902420e04 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -158,7 +158,8 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) { /* Create a temporary and convert it to the correct type. */ tmp = gfc_get_int_type (kind); - tmp = fold_convert (tmp, build_fold_indirect_ref (se->expr)); + tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location, + se->expr)); /* Test for a NULL value. */ tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp, @@ -381,7 +382,8 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, if (TYPE_STRING_FLAG (TREE_TYPE (se->expr))) tmp = se->expr; else - tmp = build_fold_indirect_ref (se->expr); + tmp = build_fold_indirect_ref_loc (input_location, + se->expr); tmp = gfc_build_array_ref (tmp, start.expr, NULL); se->expr = gfc_build_addr_expr (type, tmp); } @@ -478,7 +480,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER) || c->attr.proc_pointer) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); } @@ -621,21 +624,24 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) && (sym->attr.dummy || sym->attr.function || sym->attr.result)) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); } else if (!sym->attr.value) { /* Dereference non-character scalar dummy arguments. */ if (sym->attr.dummy && !sym->attr.dimension) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); /* Dereference scalar hidden result. */ if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX && (sym->attr.function || sym->attr.result) && !sym->attr.dimension && !sym->attr.pointer && !sym->attr.always_explicit) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); /* Dereference non-character pointer variables. These must be dummies, results, or scalars. */ @@ -644,7 +650,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) || sym->attr.function || sym->attr.result || !sym->attr.dimension)) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); } ref = expr->ref; @@ -1080,7 +1087,8 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; } - se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr); + se->expr = build_call_expr_loc (input_location, + fndecl, 2, lse.expr, rse.expr); } @@ -1171,7 +1179,8 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) else gcc_unreachable (); - tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr, + tmp = build_call_expr_loc (input_location, + fndecl, 6, len, var, lse.string_length, lse.expr, rse.string_length, rse.expr); gfc_add_expr_to_block (&se->pre, tmp); @@ -1378,7 +1387,8 @@ string_to_single_character (tree len, tree str, int kind) && TREE_INT_CST_HIGH (len) == 0) { str = fold_convert (gfc_get_pchar_type (kind), str); - return build_fold_indirect_ref (str); + return build_fold_indirect_ref_loc (input_location, + str); } return NULL_TREE; @@ -1481,7 +1491,8 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) else gcc_unreachable (); - tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2); + tmp = build_call_expr_loc (input_location, + fndecl, 4, len1, str1, len2, str2); } return tmp; @@ -1498,7 +1509,8 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tmp = gfc_get_symbol_decl (sym); if (sym->attr.proc_pointer) - tmp = build_fold_indirect_ref (tmp); + tmp = build_fold_indirect_ref_loc (input_location, + tmp); gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE); } @@ -1738,7 +1750,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, tmp = gfc_get_character_type_len (sym->ts.kind, NULL); tmp = build_pointer_type (tmp); if (sym->attr.pointer) - value = build_fold_indirect_ref (se->expr); + value = build_fold_indirect_ref_loc (input_location, + se->expr); else value = se->expr; value = fold_convert (tmp, value); @@ -1747,11 +1760,13 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, /* If the argument is a scalar, a pointer to an array or an allocatable, dereference it. */ else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable) - value = build_fold_indirect_ref (se->expr); + value = build_fold_indirect_ref_loc (input_location, + se->expr); /* For character(*), use the actual argument's descriptor. */ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length) - value = build_fold_indirect_ref (se->expr); + value = build_fold_indirect_ref_loc (input_location, + se->expr); /* If the argument is an array descriptor, use it to determine information about the actual argument's shape. */ @@ -1759,7 +1774,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))) { /* Get the actual argument's descriptor. */ - desc = build_fold_indirect_ref (se->expr); + desc = build_fold_indirect_ref_loc (input_location, + se->expr); /* Create the replacement variable. */ tmp = gfc_conv_descriptor_data_get (desc); @@ -2294,7 +2310,8 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, rse.loop->loopvar[0], offset); /* Now use the offset for the reference. */ - tmp = build_fold_indirect_ref (info->data); + tmp = build_fold_indirect_ref_loc (input_location, + info->data); rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL); if (expr->ts.type == BT_CHARACTER) @@ -2703,7 +2720,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (fsym && fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT) { - tmp = build_fold_indirect_ref (parmse.expr); + tmp = build_fold_indirect_ref_loc (input_location, + parmse.expr); tmp = gfc_trans_dealloc_allocated (tmp); gfc_add_expr_to_block (&se->pre, tmp); } @@ -2757,7 +2775,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && (e->expr_type != EXPR_VARIABLE && !e->rank)) { int parm_rank; - tmp = build_fold_indirect_ref (parmse.expr); + tmp = build_fold_indirect_ref_loc (input_location, + parmse.expr); parm_rank = e->rank; switch (parm_kind) { @@ -2767,7 +2786,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, break; case (SCALAR_POINTER): - tmp = build_fold_indirect_ref (tmp); + tmp = build_fold_indirect_ref_loc (input_location, + tmp); break; } @@ -2948,7 +2968,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))))) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); retargs = gfc_chainon_list (retargs, se->expr); } @@ -3076,7 +3097,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, where f is pointer valued, we have to dereference the result. */ if (!se->want_pointer && !byref && sym->attr.pointer && !gfc_is_proc_ptr_comp (expr, NULL)) - se->expr = build_fold_indirect_ref (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); /* f2c calling conventions require a scalar default real function to return a double precision result. Convert this back to default @@ -3123,7 +3145,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { /* Dereference for character pointer results. */ if (sym->attr.pointer || sym->attr.allocatable) - se->expr = build_fold_indirect_ref (var); + se->expr = build_fold_indirect_ref_loc (input_location, + var); else se->expr = var; @@ -3132,7 +3155,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 (var); + se->expr = build_fold_indirect_ref_loc (input_location, + var); } } } @@ -3157,7 +3181,8 @@ fill_with_spaces (tree start, tree type, tree size) /* For a simple char type, we can call memset(). */ if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0) - return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start, + return build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMSET], 3, start, build_int_cst (gfc_get_int_type (gfc_c_int_kind), lang_hooks.to_target_charset (' ')), size); @@ -3318,11 +3343,13 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, /* Truncate string if source is too long. */ cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen); - tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], + tmp2 = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMMOVE], 3, dest, src, dlen); /* Else copy and pad with spaces. */ - tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], + tmp3 = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMMOVE], 3, dest, src, slen); tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest, @@ -3465,7 +3492,7 @@ gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *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); + comp_se.expr = build_fold_addr_expr_loc (input_location, comp_se.expr); return gfc_evaluate_now (comp_se.expr, &se->pre); } @@ -4192,11 +4219,13 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) if (expr1->symtree->n.sym->attr.proc_pointer && expr1->symtree->n.sym->attr.dummy) - lse.expr = build_fold_indirect_ref (lse.expr); + lse.expr = build_fold_indirect_ref_loc (input_location, + lse.expr); if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer && expr2->symtree->n.sym->attr.dummy) - rse.expr = build_fold_indirect_ref (rse.expr); + rse.expr = build_fold_indirect_ref_loc (input_location, + rse.expr); gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); @@ -4594,7 +4623,8 @@ gfc_trans_zero_assign (gfc_expr * expr) len = fold_convert (size_type_node, len); /* Construct call to __builtin_memset. */ - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET], + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMSET], 3, dest, integer_zero_node, len); return fold_convert (void_type_node, tmp); } @@ -4622,7 +4652,8 @@ gfc_build_memcpy_call (tree dst, tree src, tree len) len = fold_convert (size_type_node, len); /* Construct call to __builtin_memcpy. */ - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len); + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len); return fold_convert (void_type_node, tmp); } -- cgit v1.2.1 From bb982f6666cf2bf5e343ac9b910303a97019135c Mon Sep 17 00:00:00 2001 From: rguenth Date: Sat, 25 Jul 2009 13:44:57 +0000 Subject: 2009-07-25 Richard Guenther PR fortran/40005 * trans-types.c (gfc_get_array_type_bounds): Use build_distinct_type_copy with a proper TYPE_CANONICAL and re-use the type-decl of the original type. * trans-decl.c (build_entry_thunks): Signal cgraph we may not garbage collect. (create_main_function): Likewise. (gfc_generate_function_code): Likewise. * trans-expr.c (gfc_trans_subcomponent_assign): Do not use fold_convert on record types. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150079 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 03902420e04..9bec2e10513 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3763,9 +3763,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) se.want_pointer = 0; gfc_conv_expr_descriptor (&se, expr, rss); gfc_add_block_to_block (&block, &se.pre); - - tmp = fold_convert (TREE_TYPE (dest), se.expr); - gfc_add_modify (&block, dest, tmp); + gfc_add_modify (&block, dest, se.expr); if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp) tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest, -- cgit v1.2.1 From 7ea64434b40d07d43f4aa6cafac4684487e69304 Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 1 Aug 2009 13:45:12 +0000 Subject: 2009-08-01 Paul Thomas PR fortran/40011 * error.c : Add static flag 'warnings_not_errors'. (gfc_error): If 'warnings_not_errors' is set, branch to code from gfc_warning. (gfc_clear_error): Reset 'warnings_not_errors'. (gfc_errors_to_warnings): New function. * options.c (gfc_post_options): If pedantic and flag_whole_file change the latter to a value of 2. * parse.c (parse_module): Add module namespace to gsymbol. (resolve_all_program_units): New function. (clean_up_modules): New function. (translate_all_program_units): New function. (gfc_parse_file): If whole_file, do not clean up module right away and add derived types to namespace derived types. In addition, call the three new functions above. * resolve.c (not_in_recursive): New function. (not_entry_self_reference): New function. (resolve_global_procedure): Symbol must not be IFSRC_UNKNOWN, procedure must not be in the course of being resolved and must return false for the two new functions. Pack away the current derived type list before calling gfc_resolve for the gsymbol namespace. It is unconditionally an error if the ranks of the reference and ther procedure do not match. Convert errors to warnings during call to gfc_procedure_use if not pedantic or legacy. (gfc_resolve): Set namespace resolved flag to -1 during resolution and store current cs_base. * trans-decl.c (gfc_get_symbol_decl): If whole_file compilation substitute a use associated variable, if it is available in a gsymbolnamespace. (gfc_get_extern_function_decl): If the procedure is use assoc, do not attempt to find it in a gsymbol because it could be an interface. If the symbol exists in a module namespace, return its backend_decl. * trans-expr.c (gfc_trans_scalar_assign): If a derived type assignment, set the rhs TYPE_MAIN_VARIANT to that of the rhs. * trans-types.c (copy_dt_decls_ifequal): Add 'from_gsym' as a boolean argument. Copy component backend_decls directly if the components are derived types and from_gsym is true. (gfc_get_derived_type): If whole_file copy the derived type from the module if it is use associated, otherwise, if can be found in another gsymbol namespace, use the existing derived type as the TYPE_CANONICAL and build normally. * gfortran.h : Add derived_types and resolved fields to gfc_namespace. Include prototype for gfc_errors_to_warnings. 2009-08-01 Paul Thomas PR fortran/40011 * gfortran.dg/whole_file_7.f90: New test. * gfortran.dg/whole_file_8.f90: New test. * gfortran.dg/whole_file_9.f90: New test. * gfortran.dg/whole_file_10.f90: New test. * gfortran.dg/whole_file_11.f90: New test. * gfortran.dg/whole_file_12.f90: New test. * gfortran.dg/whole_file_13.f90: New test. * gfortran.dg/whole_file_14.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150333 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 9bec2e10513..7352db849e0 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4436,8 +4436,24 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); + /* TODO This is rather obviously the wrong place to do this. + However, a number of testcases, such as function_kinds_1 + and function_types_2 fail without it, by ICEing at + fold_const: 2710 (fold_convert_loc). */ + if (ts.type == BT_DERIVED + && gfc_option.flag_whole_file + && (TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)) + != TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr)))) + { + tmp = gfc_evaluate_now (rse->expr, &block); + TYPE_MAIN_VARIANT (TREE_TYPE (tmp)) + = TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr)); + } + else + tmp = rse->expr; + gfc_add_modify (&block, lse->expr, - fold_convert (TREE_TYPE (lse->expr), rse->expr)); + fold_convert (TREE_TYPE (lse->expr), tmp)); } gfc_add_block_to_block (&block, &lse->post); -- cgit v1.2.1 From cf046737dfbfc289c2c94e10b3d7dd9546d6431d Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 11 Aug 2009 20:08:35 +0000 Subject: 2009-08-11 Janus Weil PR fortran/41022 * trans-expr.c (gfc_conv_procedure_call): Handle procedure pointer components as actual arguments. 2009-08-11 Janus Weil PR fortran/41022 * gfortran.dg/proc_ptr_comp_14.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150665 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7352db849e0..a6e129b1406 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2679,7 +2679,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && fsym->attr.flavor != FL_PROCEDURE) || (fsym->attr.proc_pointer && !(e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.dummy)))) + && e->symtree->n.sym->attr.dummy)) + || gfc_is_proc_ptr_comp (e, NULL))) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains -- cgit v1.2.1 From eeebe20ba63ca092de5e2d4575b5765dd88a7ce6 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 13 Aug 2009 19:46:46 +0000 Subject: 2009-08-13 Janus Weil PR fortran/40941 * gfortran.h (gfc_typespec): Put 'derived' and 'cl' into union. * decl.c (build_struct): Make sure 'cl' is only used if type is BT_CHARACTER. * symbol.c (gfc_set_default_type): Ditto. * resolve.c (resolve_symbol, resolve_fl_derived): Ditto. (resolve_equivalence,resolve_equivalence_derived): Make sure 'derived' is only used if type is BT_DERIVED. * trans-io.c (transfer_expr): Make sure 'derived' is only used if type is BT_DERIVED or BT_INTEGER (special case: C_PTR/C_FUNPTR). * array.c: Mechanical replacements to accomodate union in gfc_typespec. * check.c: Ditto. * data.c: Ditto. * decl.c: Ditto. * dump-parse-tree.c: Ditto. * expr.c: Ditto. * interface.c: Ditto. * iresolve.c: Ditto. * match.c: Ditto. * misc.c: Ditto. * module.c: Ditto. * openmp.c: Ditto. * parse.c: Ditto. * primary.c: Ditto. * resolve.c: Ditto. * simplify.c: Ditto. * symbol.c: Ditto. * target-memory.c: Ditto. * trans-array.c: Ditto. * trans-common.c: Ditto. * trans-const.c: Ditto. * trans-decl.c: Ditto. * trans-expr.c: Ditto. * trans-intrinsic.c: Ditto. * trans-io.c: Ditto. * trans-stmt.c: Ditto. * trans-types.c: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150725 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 176 +++++++++++++++++++++++------------------------ 1 file changed, 88 insertions(+), 88 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index a6e129b1406..51593e7ae19 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -201,12 +201,12 @@ gfc_get_expr_charlen (gfc_expr *e) length = NULL; /* To silence compiler warning. */ - if (is_subref_array (e) && e->ts.cl->length) + if (is_subref_array (e) && e->ts.u.cl->length) { gfc_se tmpse; gfc_init_se (&tmpse, NULL); - gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node); - e->ts.cl->backend_decl = tmpse.expr; + gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node); + e->ts.u.cl->backend_decl = tmpse.expr; return tmpse.expr; } @@ -214,7 +214,7 @@ gfc_get_expr_charlen (gfc_expr *e) expression's length could be the length of the character variable. */ if (e->symtree->n.sym->ts.type == BT_CHARACTER) - length = e->symtree->n.sym->ts.cl->backend_decl; + length = e->symtree->n.sym->ts.u.cl->backend_decl; /* Look through the reference chain for component references. */ for (r = e->ref; r; r = r->next) @@ -223,7 +223,7 @@ gfc_get_expr_charlen (gfc_expr *e) { case REF_COMPONENT: if (r->u.c.component->ts.type == BT_CHARACTER) - length = r->u.c.component->ts.cl->backend_decl; + length = r->u.c.component->ts.u.cl->backend_decl; break; case REF_ARRAY: @@ -243,7 +243,7 @@ gfc_get_expr_charlen (gfc_expr *e) } -/* For each character array constructor subexpression without a ts.cl->length, +/* For each character array constructor subexpression without a ts.u.cl->length, replace it by its first element (if there aren't any elements, the length should already be set to zero). */ @@ -276,7 +276,7 @@ flatten_array_ctors_without_strlen (gfc_expr* e) case EXPR_ARRAY: /* We've found what we're looking for. */ - if (e->ts.type == BT_CHARACTER && !e->ts.cl->length) + if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length) { gfc_expr* new_expr; gcc_assert (e->value.constructor); @@ -472,7 +472,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) if (c->ts.type == BT_CHARACTER) { - tmp = c->ts.cl->backend_decl; + tmp = c->ts.u.cl->backend_decl; /* Components must always be constant length. */ gcc_assert (tmp && INTEGER_CST_P (tmp)); se->string_length = tmp; @@ -513,7 +513,7 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref) /* Otherwise build the reference and call self. */ gfc_conv_component_ref (se, &parent); - parent.u.c.sym = dt->components->ts.derived; + parent.u.c.sym = dt->components->ts.u.derived; parent.u.c.component = c; conv_parent_component_references (se, &parent); } @@ -662,10 +662,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) { /* If the character length of an entry isn't set, get the length from the master function instead. */ - if (sym->attr.entry && !sym->ts.cl->backend_decl) - se->string_length = sym->ns->proc_name->ts.cl->backend_decl; + if (sym->attr.entry && !sym->ts.u.cl->backend_decl) + se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl; else - se->string_length = sym->ts.cl->backend_decl; + se->string_length = sym->ts.u.cl->backend_decl; gcc_assert (se->string_length); } @@ -1159,7 +1159,7 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) gfc_add_block_to_block (&se->pre, &lse.pre); gfc_add_block_to_block (&se->pre, &rse.pre); - type = gfc_get_character_type (expr->ts.kind, expr->ts.cl); + type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl); len = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); if (len == NULL_TREE) { @@ -1723,16 +1723,16 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, if (sym->ts.type == BT_CHARACTER) { /* Create a copy of the dummy argument's length. */ - new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl); - sm->expr->ts.cl = new_sym->ts.cl; + new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl); + sm->expr->ts.u.cl = new_sym->ts.u.cl; /* If the length is specified as "*", record the length that the caller is passing. We should use the callee's length in all other cases. */ - if (!new_sym->ts.cl->length && se) + if (!new_sym->ts.u.cl->length && se) { se->string_length = gfc_evaluate_now (se->string_length, &se->pre); - new_sym->ts.cl->backend_decl = se->string_length; + new_sym->ts.u.cl->backend_decl = se->string_length; } } @@ -1764,7 +1764,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, se->expr); /* For character(*), use the actual argument's descriptor. */ - else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length) + else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length) value = build_fold_indirect_ref_loc (input_location, se->expr); @@ -1809,9 +1809,9 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping, for (sym = mapping->syms; sym; sym = sym->next) if (sym->new_sym->n.sym->ts.type == BT_CHARACTER - && !sym->new_sym->n.sym->ts.cl->backend_decl) + && !sym->new_sym->n.sym->ts.u.cl->backend_decl) { - expr = sym->new_sym->n.sym->ts.cl->length; + expr = sym->new_sym->n.sym->ts.u.cl->length; gfc_apply_interface_mapping_to_expr (mapping, expr); gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); @@ -1820,7 +1820,7 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping, gfc_add_block_to_block (pre, &se.pre); gfc_add_block_to_block (post, &se.post); - sym->new_sym->n.sym->ts.cl->backend_decl = se.expr; + sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr; } } @@ -1907,12 +1907,12 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) case GFC_ISYM_LEN: /* TODO figure out why this condition is necessary. */ if (sym->attr.function - && (arg1->ts.cl->length == NULL - || (arg1->ts.cl->length->expr_type != EXPR_CONSTANT - && arg1->ts.cl->length->expr_type != EXPR_VARIABLE))) + && (arg1->ts.u.cl->length == NULL + || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT + && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE))) return false; - new_expr = gfc_copy_expr (arg1->ts.cl->length); + new_expr = gfc_copy_expr (arg1->ts.u.cl->length); break; case GFC_ISYM_SIZE: @@ -2025,11 +2025,11 @@ gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr, if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER) { - expr->value.function.esym->ts.cl->length - = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length); + expr->value.function.esym->ts.u.cl->length + = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length); gfc_apply_interface_mapping_to_expr (mapping, - expr->value.function.esym->ts.cl->length); + expr->value.function.esym->ts.u.cl->length); } } @@ -2050,10 +2050,10 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, return; /* Copying an expression does not copy its length, so do that here. */ - if (expr->ts.type == BT_CHARACTER && expr->ts.cl) + if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl) { - expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl); - gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length); + expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl); + gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length); } /* Apply the mapping to any references. */ @@ -2173,8 +2173,8 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, gfc_conv_ss_startstride (&loop); /* Build an ss for the temporary. */ - if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl) - gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre); + if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl) + gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre); base_type = gfc_typenode_for_spec (&expr->ts); if (GFC_ARRAY_TYPE_P (base_type) @@ -2186,7 +2186,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, loop.temp_ss->data.temp.type = base_type; if (expr->ts.type == BT_CHARACTER) - loop.temp_ss->string_length = expr->ts.cl->backend_decl; + loop.temp_ss->string_length = expr->ts.u.cl->backend_decl; else loop.temp_ss->string_length = NULL; @@ -2315,7 +2315,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL); if (expr->ts.type == BT_CHARACTER) - rse.string_length = expr->ts.cl->backend_decl; + rse.string_length = expr->ts.u.cl->backend_decl; gfc_conv_expr (&lse, expr); @@ -2343,7 +2343,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, /* Pass the string length to the argument expression. */ if (expr->ts.type == BT_CHARACTER) - parmse->string_length = expr->ts.cl->backend_decl; + parmse->string_length = expr->ts.u.cl->backend_decl; /* We want either the address for the data or the address of the descriptor, depending on the mode of passing array arguments. */ @@ -2457,9 +2457,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC) { - arg->expr->ts.type = sym->ts.derived->ts.type; - arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type; - arg->expr->ts.kind = sym->ts.derived->ts.kind; + arg->expr->ts.type = sym->ts.u.derived->ts.type; + arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type; + arg->expr->ts.kind = sym->ts.u.derived->ts.kind; gfc_conv_expr_reference (se, arg->expr); return 0; @@ -2572,8 +2572,8 @@ 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.cl->length - && sym->ts.cl->length->expr_type + && sym->ts.u.cl->length + && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) || (comp && comp->attr.dimension) || (!comp && sym->attr.dimension)); @@ -2753,11 +2753,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && parmse.string_length == NULL_TREE && e->ts.type == BT_PROCEDURE && e->symtree->n.sym->ts.type == BT_CHARACTER - && e->symtree->n.sym->ts.cl->length != NULL - && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT) + && e->symtree->n.sym->ts.u.cl->length != NULL + && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) { - gfc_conv_const_charlen (e->symtree->n.sym->ts.cl); - parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl; + gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl); + parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl; } } @@ -2771,7 +2771,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, deallocated for non-variable scalars. Non-variable arrays are dealt with in trans-array.c(gfc_conv_array_parameter). */ if (e && e->ts.type == BT_DERIVED - && e->ts.derived->attr.alloc_comp + && e->ts.u.derived->attr.alloc_comp && !(e->symtree && e->symtree->n.sym->attr.pointer) && (e->expr_type != EXPR_VARIABLE && !e->rank)) { @@ -2798,11 +2798,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tree local_tmp; local_tmp = gfc_evaluate_now (tmp, &se->pre); - local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank); + local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank); gfc_add_expr_to_block (&se->post, local_tmp); } - tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank); + tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank); gfc_add_expr_to_block (&se->post, tmp); } @@ -2912,7 +2912,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, se->string_length = build_int_cst (gfc_charlen_type_node, 1); else if (ts.type == BT_CHARACTER) { - if (sym->ts.cl->length == NULL) + if (sym->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 @@ -2927,7 +2927,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, formal = sym->ns->proc_name->formal; for (; formal; formal = formal->next) if (strcmp (formal->sym->name, sym->name) == 0) - cl.backend_decl = formal->sym->ts.cl->backend_decl; + cl.backend_decl = formal->sym->ts.u.cl->backend_decl; } } else @@ -2937,9 +2937,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.cl->length); + gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.u.cl->length); else - gfc_conv_expr (&parmse, sym->ts.cl->length); + gfc_conv_expr (&parmse, sym->ts.u.cl->length); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&se->post, &parmse.post); @@ -2952,7 +2952,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Set up a charlen structure for it. */ cl.next = NULL; cl.length = NULL; - ts.cl = &cl; + ts.u.cl = &cl; len = cl.backend_decl; } @@ -3025,7 +3025,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else if (ts.type == BT_CHARACTER) { /* Pass the string length. */ - type = gfc_get_character_type (ts.kind, ts.cl); + type = gfc_get_character_type (ts.kind, ts.u.cl); type = build_pointer_type (type); /* Return an address to a char[0:len-1]* temporary for @@ -3419,8 +3419,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) /* Copy string arguments. */ tree arglen; - gcc_assert (fsym->ts.cl && fsym->ts.cl->length - && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); + gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length + && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT); arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); tmp = gfc_build_addr_expr (build_pointer_type (type), @@ -3457,22 +3457,22 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) if (sym->ts.type == BT_CHARACTER) { - gfc_conv_const_charlen (sym->ts.cl); + gfc_conv_const_charlen (sym->ts.u.cl); /* Force the expression to the correct length. */ if (!INTEGER_CST_P (se->string_length) || tree_int_cst_lt (se->string_length, - sym->ts.cl->backend_decl)) + sym->ts.u.cl->backend_decl)) { - type = gfc_get_character_type (sym->ts.kind, sym->ts.cl); + type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl); tmp = gfc_create_var (type, sym->name); tmp = gfc_build_addr_expr (build_pointer_type (type), tmp); - gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp, + gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp, sym->ts.kind, se->string_length, se->expr, sym->ts.kind); se->expr = tmp; } - se->string_length = sym->ts.cl->backend_decl; + se->string_length = sym->ts.u.cl->backend_decl; } /* Restore the original variables. */ @@ -3559,9 +3559,9 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, used as initialization expressions). If so, we need to modify the 'expr' to be that for a (void *). */ if (expr != NULL && expr->ts.type == BT_DERIVED - && expr->ts.is_iso_c && expr->ts.derived) + && expr->ts.is_iso_c && expr->ts.u.derived) { - gfc_symbol *derived = expr->ts.derived; + gfc_symbol *derived = expr->ts.u.derived; expr = gfc_int_expr (0); @@ -3591,7 +3591,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, return se.expr; case BT_CHARACTER: - return gfc_conv_string_init (ts->cl->backend_decl,expr); + return gfc_conv_string_init (ts->u.cl->backend_decl,expr); default: gfc_init_se (&se, NULL); @@ -3679,7 +3679,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_tmp_array_ref (&lse); if (cm->ts.type == BT_CHARACTER) - lse.string_length = cm->ts.cl->backend_decl; + lse.string_length = cm->ts.u.cl->backend_decl; gfc_conv_expr (&rse, expr); @@ -3766,8 +3766,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_add_block_to_block (&block, &se.pre); gfc_add_modify (&block, dest, se.expr); - if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp) - tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest, + if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp) + tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest, cm->as->rank); else tmp = gfc_duplicate_allocatable (dest, se.expr, @@ -3872,7 +3872,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_expr (&se, expr); if (cm->ts.type == BT_CHARACTER) - lse.string_length = cm->ts.cl->backend_decl; + lse.string_length = cm->ts.u.cl->backend_decl; lse.expr = dest; tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false); gfc_add_expr_to_block (&block, tmp); @@ -3892,7 +3892,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) tree tmp; gfc_start_block (&block); - cm = expr->ts.derived->components; + cm = expr->ts.u.derived->components; for (c = expr->value.constructor; c; c = c->next, cm = cm->next) { /* Skip absent members in default initializers. */ @@ -3928,13 +3928,13 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!init) { /* Create a temporary variable and fill it in. */ - se->expr = gfc_create_var (type, expr->ts.derived->name); + se->expr = gfc_create_var (type, expr->ts.u.derived->name); tmp = gfc_trans_structure_assign (se->expr, expr); gfc_add_expr_to_block (&se->pre, tmp); return; } - cm = expr->ts.derived->components; + cm = expr->ts.u.derived->components; for (c = expr->value.constructor; c; c = c->next, cm = cm->next) { @@ -4004,8 +4004,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) null_pointer_node. C_PTR and C_FUNPTR are converted to match the typespec for the C_PTR and C_FUNPTR symbols, which has already been updated to be an integer with a kind equal to the size of a (void *). */ - if (expr->ts.type == BT_DERIVED && expr->ts.derived - && expr->ts.derived->attr.is_iso_c) + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived + && expr->ts.u.derived->attr.is_iso_c) { if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR) @@ -4018,9 +4018,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) { /* Update the type/kind of the expression to be what the new type/kind are for the updated symbols of C_PTR/C_FUNPTR. */ - expr->ts.type = expr->ts.derived->ts.type; - expr->ts.f90_type = expr->ts.derived->ts.f90_type; - expr->ts.kind = expr->ts.derived->ts.kind; + expr->ts.type = expr->ts.u.derived->ts.type; + expr->ts.f90_type = expr->ts.u.derived->ts.f90_type; + expr->ts.kind = expr->ts.u.derived->ts.kind; } } @@ -4389,7 +4389,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen, rse->expr, ts.kind); } - else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp) + else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { cond = NULL_TREE; @@ -4409,7 +4409,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, if (!l_is_temp) { tmp = gfc_evaluate_now (lse->expr, &lse->pre); - tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0); + tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); if (r_is_var) tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), tmp); @@ -4426,7 +4426,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, same as the lhs. */ if (r_is_var) { - tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0); + tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0); tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), tmp); gfc_add_expr_to_block (&block, tmp); @@ -4504,16 +4504,16 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) character lengths are the same. */ if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0) { - if (expr1->ts.cl->length == NULL - || expr1->ts.cl->length->expr_type != EXPR_CONSTANT) + if (expr1->ts.u.cl->length == NULL + || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT) return NULL; - if (expr2->ts.cl->length == NULL - || expr2->ts.cl->length->expr_type != EXPR_CONSTANT) + if (expr2->ts.u.cl->length == NULL + || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT) return NULL; - if (mpz_cmp (expr1->ts.cl->length->value.integer, - expr2->ts.cl->length->value.integer) != 0) + if (mpz_cmp (expr1->ts.u.cl->length->value.integer, + expr2->ts.u.cl->length->value.integer) != 0) return NULL; } @@ -4887,13 +4887,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) to arrays must be done with a deep copy and the rhs temporary must have its components deallocated afterwards. */ scalar_to_array = (expr2->ts.type == BT_DERIVED - && expr2->ts.derived->attr.alloc_comp + && expr2->ts.u.derived->attr.alloc_comp && expr2->expr_type != EXPR_VARIABLE && !gfc_is_constant_expr (expr2) && expr1->rank && !expr2->rank); if (scalar_to_array) { - tmp = gfc_deallocate_alloc_comp (expr2->ts.derived, rse.expr, 0); + tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0); gfc_add_expr_to_block (&loop.post, tmp); } @@ -4983,7 +4983,7 @@ copyable_array_p (gfc_expr * expr) return false; case BT_DERIVED: - return !expr->ts.derived->attr.alloc_comp; + return !expr->ts.u.derived->attr.alloc_comp; default: break; -- cgit v1.2.1 From 816767a6ad07ac3ef96e45d95d107372f170dd28 Mon Sep 17 00:00:00 2001 From: rguenth Date: Sun, 16 Aug 2009 22:36:13 +0000 Subject: 2009-08-17 Richard Guenther * trans-expr.c (gfc_trans_scalar_assign): Replace hack with more proper hack. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150817 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 26 +++++++++----------------- 1 file changed, 9 insertions(+), 17 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 51593e7ae19..144c20441e9 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4432,29 +4432,21 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_expr_to_block (&block, tmp); } } + else if (ts.type == BT_DERIVED) + { + gfc_add_block_to_block (&block, &lse->pre); + gfc_add_block_to_block (&block, &rse->pre); + tmp = gfc_evaluate_now (rse->expr, &block); + tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr); + gfc_add_modify (&block, lse->expr, tmp); + } else { gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); - /* TODO This is rather obviously the wrong place to do this. - However, a number of testcases, such as function_kinds_1 - and function_types_2 fail without it, by ICEing at - fold_const: 2710 (fold_convert_loc). */ - if (ts.type == BT_DERIVED - && gfc_option.flag_whole_file - && (TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)) - != TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr)))) - { - tmp = gfc_evaluate_now (rse->expr, &block); - TYPE_MAIN_VARIANT (TREE_TYPE (tmp)) - = TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr)); - } - else - tmp = rse->expr; - gfc_add_modify (&block, lse->expr, - fold_convert (TREE_TYPE (lse->expr), tmp)); + fold_convert (TREE_TYPE (lse->expr), rse->expr)); } gfc_add_block_to_block (&block, &lse->post); -- cgit v1.2.1 From e1b3b79beacf0e6747eb7e6a1055d3cd0a436327 Mon Sep 17 00:00:00 2001 From: matz Date: Wed, 19 Aug 2009 10:17:33 +0000 Subject: * tree-ssa-structalias.c (create_variable_info_for): Also mark first field in a struct. (intra_create_variable_infos): Don't deal with flag_argument_noalias. fortran/ * trans-expr.c (gfc_conv_substring): Don't evaluate casted decl early, change order of length calculation to (end - start) + 1. (gfc_get_interface_mapping_array): Adjust call to gfc_get_nodesc_array_type. * trans-array.c (gfc_trans_create_temp_array, gfc_build_constant_array_constructor, gfc_conv_expr_descriptor): Ditto. * trans-stmt.c (gfc_trans_pointer_assign_need_temp): Ditto. * trans.c (gfc_add_modify): Assignment between base type and nontarget type are equal enough. (gfc_call_malloc): Use prvoid_type_node for return value of __builtin_malloc. (gfc_allocate_with_status): Ditto. * trans-types.c (gfc_array_descriptor_base): Double size of this array. (gfc_init_types): Build prvoid_type_node. (gfc_build_array_type): New bool parameter "restricted". (gfc_get_nodesc_array_type): Ditto, build restrict qualified pointers, if it's true. (gfc_get_array_descriptor_base): Ditto. (gfc_get_array_type_bounds): Ditto. (gfc_sym_type): Use symbol attributes to feed calls to above functions. (gfc_get_derived_type): Ditto. * trans.h (struct lang_type): Add nontarget_type member. * trans-types.h (prvoid_type_node): Declare. (gfc_get_array_type_bounds, gfc_get_nodesc_array_type): Declare new parameter. * trans-decl.c (gfc_finish_var_decl): Give scalars that can't be aliased a type with a different alias set than the base type. (gfc_build_dummy_array_decl): Adjust call to gfc_get_nodesc_array_type. testsuite/ * gfortran.dg/vect/vect-gems.f90: New test. * gcc.dg/tree-ssa/alias-1.c: Remove, it checks something broken. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150934 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 144c20441e9..7672f0b092d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -374,8 +374,10 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, gfc_conv_string_parameter (se); else { + tmp = start.expr; + STRIP_NOPS (tmp); /* Avoid multiple evaluation of substring start. */ - if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr)) + if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp)) start.expr = gfc_evaluate_now (start.expr, &se->pre); /* Change the start of the string. */ @@ -397,7 +399,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node); gfc_add_block_to_block (&se->pre, &end.pre); } - if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr)) + tmp = end.expr; + STRIP_NOPS (tmp); + if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp)) end.expr = gfc_evaluate_now (end.expr, &se->pre); if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) @@ -440,9 +444,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, } tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, - build_int_cst (gfc_charlen_type_node, 1), - start.expr); - tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp); + end.expr, start.expr); + tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, + build_int_cst (gfc_charlen_type_node, 1), tmp); tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp, build_int_cst (gfc_charlen_type_node, 0)); se->string_length = tmp; @@ -1611,7 +1615,9 @@ gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym, tree var; type = gfc_typenode_for_spec (&sym->ts); - type = gfc_get_nodesc_array_type (type, sym->as, packed); + type = gfc_get_nodesc_array_type (type, sym->as, packed, + !sym->attr.target && !sym->attr.pointer + && !sym->attr.proc_pointer); var = gfc_create_var (type, "ifm"); gfc_add_modify (block, var, fold_convert (type, data)); -- cgit v1.2.1 From f76d4106229562a9c2897e979d1eea60eac39741 Mon Sep 17 00:00:00 2001 From: matz Date: Thu, 20 Aug 2009 14:25:36 +0000 Subject: fortran/ * trans-expr.c (gfc_conv_string_tmp): Check type compatibility instead of equality. testsuite/ * gfortran.dg/pr41126.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150964 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7672f0b092d..c2c1f0fbed4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1104,7 +1104,7 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) tree var; tree tmp; - gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node); + gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node)); if (gfc_can_put_var_on_stack (len)) { -- cgit v1.2.1 From 1d84f30a09bc526c646dbbbef88787b991feca8f Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 21 Aug 2009 09:43:04 +0000 Subject: 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 --- gcc/fortran/trans-expr.c | 67 +++++++++++++++++++++++++++++------------------- 1 file changed, 41 insertions(+), 26 deletions(-) (limited to 'gcc/fortran/trans-expr.c') 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); -- cgit v1.2.1 From 0fd53ac9e79421de9b0d1f42521f15e9845983e7 Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 25 Aug 2009 14:26:44 +0000 Subject: 2009-08-25 Janus Weil PR fortran/41139 * primary.c (gfc_match_varspec): Make sure EXPR_PPC is only used for calls to procedure pointer components, other references to procedure pointer components are EXPR_VARIABLE. * resolve.c (resolve_actual_arglist): Bugfix (there can be calls without actual arglist). * trans-expr.c (gfc_get_proc_ptr_comp): Renamed to 'get_proc_ptr_comp', removed argument 'se' and made static. Avoid inserting a temporary variable for calling the PPC. (conv_function_val): Renamed gfc_get_proc_ptr_comp. (gfc_conv_procedure_call): Distinguish functions returning a procedure pointer from calls to a procedure pointer. Distinguish calls to procedure pointer components from procedure pointer components as actual arguments. * trans-stmt.h (gfc_get_proc_ptr_comp): Make it static. 2009-08-25 Janus Weil PR fortran/41139 * gfortran.dg/proc_ptr_25.f90: New. * gfortran.dg/proc_ptr_comp_18.f90: New. * gfortran.dg/proc_ptr_comp_19.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151081 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 38 ++++++++++++++++++++------------------ 1 file changed, 20 insertions(+), 18 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3f5e76d137d..a5677f70d8d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1502,13 +1502,29 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) return tmp; } + +/* Return the backend_decl for a procedure pointer component. */ + +static tree +get_proc_ptr_comp (gfc_expr *e) +{ + gfc_se comp_se; + gfc_expr *e2; + gfc_init_se (&comp_se, NULL); + e2 = gfc_copy_expr (e); + e2->expr_type = EXPR_VARIABLE; + gfc_conv_expr (&comp_se, e2); + return build_fold_addr_expr_loc (input_location, comp_se.expr); +} + + static void conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tree tmp; if (gfc_is_proc_ptr_comp (expr, NULL)) - tmp = gfc_get_proc_ptr_comp (se, expr); + tmp = get_proc_ptr_comp (expr); else if (sym->attr.dummy) { tmp = gfc_get_symbol_decl (sym); @@ -2679,6 +2695,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else if (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym->result + && e->symtree->n.sym->result != e->symtree->n.sym && e->symtree->n.sym->result->attr.proc_pointer) { /* Functions returning procedure pointers. */ @@ -2695,7 +2712,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, || (fsym->attr.proc_pointer && !(e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)) - || gfc_is_proc_ptr_comp (e, NULL))) + || (e->expr_type == EXPR_VARIABLE + && gfc_is_proc_ptr_comp (e, NULL)))) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains @@ -3501,22 +3519,6 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) } -/* Return the backend_decl for a procedure pointer component. */ - -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); - e2 = gfc_copy_expr (e); - e2->expr_type = EXPR_VARIABLE; - gfc_conv_expr (&comp_se, e2); - comp_se.expr = build_fold_addr_expr_loc (input_location, comp_se.expr); - return gfc_evaluate_now (comp_se.expr, &se->pre); -} - - /* Translate a function expression. */ static void -- cgit v1.2.1 From 52f5c19d04fe626cee42f247fbab091b8eaedeff Mon Sep 17 00:00:00 2001 From: kargl Date: Sat, 29 Aug 2009 19:06:11 +0000 Subject: 2009-08-29 Steven G. Kargl * trans-expr.c(gfc_trans_assignment_1): Correct a comment. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151205 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index a5677f70d8d..3d675eb0499 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4786,7 +4786,7 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) /* Subroutine of gfc_trans_assignment that actually scalarizes the - assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */ + assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */ static tree gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) -- cgit v1.2.1 From 8860b4e81d8b98c65f94fb68f839d1b32883990e Mon Sep 17 00:00:00 2001 From: pault Date: Wed, 9 Sep 2009 20:03:49 +0000 Subject: 2009-09-09 Richard Guenther PR fortran/41297 * trans-expr.c (gfc_trans_scalar_assign): Correct typo that left 'tmp' unused in derived type assignment. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151576 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3d675eb0499..b3642c2232c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4460,7 +4460,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); tmp = gfc_evaluate_now (rse->expr, &block); - tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr); + tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), tmp); gfc_add_modify (&block, lse->expr, tmp); } else -- cgit v1.2.1 From 1de1b1a9e40b5aa064d5e3d032dd43ce14f6d2ad Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 30 Sep 2009 19:55:45 +0000 Subject: fortran/ 2009-09-30 Janus Weil * check.c (gfc_check_same_type_as): New function for checking SAME_TYPE_AS and EXTENDS_TYPE_OF. * decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class container, if the contained type has it. Add an initializer for the class container. (add_init_expr_to_sym): Handle BT_CLASS. (vindex_counter): New counter for setting vindices. (gfc_match_derived_decl): Set vindex for all derived types, not only those which are being extended. * expr.c (gfc_check_assign_symbol): Handle NULL initialization of class pointers. * gfortran.h (gfc_isym_id): New values GFC_ISYM_SAME_TYPE_AS and GFC_ISYM_EXTENDS_TYPE_OF. (gfc_type_is_extensible): New prototype. * intrinsic.h (gfc_check_same_type_as): New prototype. * intrinsic.c (add_functions): Add SAME_TYPE_AS and EXTENDS_TYPE_OF. * primary.c (gfc_expr_attr): Handle CLASS-valued functions. * resolve.c (resolve_structure_cons): Handle BT_CLASS. (type_is_extensible): Make non-static and rename to 'gfc_type_is_extensible. (resolve_select_type): Renamed type_is_extensible. (resolve_class_assign): Handle NULL pointers. (resolve_fl_variable_derived): Renamed type_is_extensible. (resolve_fl_derived): Ditto. * trans-expr.c (gfc_trans_subcomponent_assign): Handle NULL initialization of class pointer components. (gfc_conv_structure): Handle BT_CLASS. * trans-intrinsic.c (gfc_conv_same_type_as,gfc_conv_extends_type_of): New functions. (gfc_conv_intrinsic_function): Handle SAME_TYPE_AS and EXTENDS_TYPE_OF. 2009-09-30 Janus Weil * gfortran.h (type_selector, select_type_tmp): New global variables. * match.c (type_selector, select_type_tmp): New global variables, used for SELECT TYPE statements. (gfc_match_select_type): Better error handling. Remember selector. (gfc_match_type_is): Create temporary variable. * module.c (ab_attribute): New value 'AB_IS_CLASS'. (attr_bits): New string. (mio_symbol_attribute): Handle 'is_class'. * resolve.c (resolve_select_type): Insert pointer assignment statement, to assign temporary to selector. * symbol.c (gfc_get_ha_sym_tree): Replace selector by a temporary in SELECT TYPE statements. 2009-09-30 Janus Weil * dump-parse-tree.c (show_code_node): Renamed 'alloc_list'. * gfortran.h (gfc_code): Rename 'alloc_list'. Add member 'ts'. (gfc_expr_to_initialize): New prototype. * match.c (alloc_opt_list): Correctly check type compatibility. Renamed 'alloc_list'. (dealloc_opt_list): Renamed 'alloc_list'. * resolve.c (expr_to_initialize): Rename to 'gfc_expr_to_initialize' and make it non-static. (resolve_allocate_expr): Set vindex for CLASS variables correctly. Move initialization code to gfc_trans_allocate. Renamed 'alloc_list'. (resolve_allocate_deallocate): Renamed 'alloc_list'. (check_class_pointer_assign): Rename to 'resolve_class_assign'. Change argument type. Adjust to work with ordinary assignments. (resolve_code): Call 'resolve_class_assign' for ordinary assignments. Renamed 'check_class_pointer_assign'. * st.c (gfc_free_statement): Renamed 'alloc_list'. * trans-stmt.c (gfc_trans_allocate): Renamed 'alloc_list'. Handle size determination and initialization of CLASS variables. Bugfix for ALLOCATE statements with default initialization and SOURCE block. (gfc_trans_deallocate): Renamed 'alloc_list'. 2009-09-30 Paul Thomas * trans-expr.c (gfc_conv_procedure_call): Convert a derived type actual to a class object if the formal argument is a class. 2009-09-30 Janus Weil PR fortran/40996 * decl.c (build_struct): Handle allocatable scalar components. * expr.c (gfc_add_component_ref): Correctly set typespec of expression, after inserting component reference. * match.c (gfc_match_type_is,gfc_match_class_is): Make sure that no variables are being used uninitialized. * primary.c (gfc_match_varspec): Handle CLASS array components. * resolve.c (resolve_select_type): Transform EXEC_SELECT_TYPE to EXEC_SELECT. * trans-array.c (structure_alloc_comps,gfc_trans_deferred_array): Handle allocatable scalar components. * trans-expr.c (gfc_conv_component_ref): Ditto. * trans-types.c (gfc_get_derived_type): Ditto. 2009-09-30 Janus Weil * decl.c (encapsulate_class_symbol): Modify names of class container components by prefixing with '$'. (gfc_match_end): Handle COMP_SELECT_TYPE. * expr.c (gfc_add_component_ref): Modify names of class container components by prefixing with '$'. * gfortran.h (gfc_statement): Add ST_SELECT_TYPE, ST_TYPE_IS and ST_CLASS_IS. (gfc_case): New field 'ts'. (gfc_exec_op): Add EXEC_SELECT_TYPE. (gfc_type_is_extension_of): New prototype. * match.h (gfc_match_select_type,gfc_match_type_is,gfc_match_class_is): New prototypes. * match.c (match_derived_type_spec): New function. (match_type_spec): Use 'match_derived_type_spec'. (match_case_eos): Modify error message. (gfc_match_select_type): New function. (gfc_match_case): Modify error message. (gfc_match_type_is): New function. (gfc_match_class_is): Ditto. * parse.h (gfc_compile_state): Add COMP_SELECT_TYPE. * parse.c (decode_statement): Handle SELECT TYPE, TYPE IS and CLASS IS statements. (next_statement): Handle ST_SELECT_TYPE. (gfc_ascii_statement): Handle ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS. (parse_select_type_block): New function. (parse_executable): Handle ST_SELECT_TYPE. * resolve.c (resolve_deallocate_expr): Handle BT_CLASS. Modify names of class container components by prefixing with '$'. (resolve_allocate_expr): Ditto. (resolve_select_type): New function. (gfc_resolve_blocks): Handle EXEC_SELECT_TYPE. (check_class_pointer_assign): Modify names of class container components by prefixing with '$'. (resolve_code): Ditto. * st.c (gfc_free_statement): Ditto. * symbol.c (gfc_type_is_extension_of): New function. (gfc_type_compatible): Use 'gfc_type_is_extension_of', plus a bugfix. * trans.c (gfc_trans_code): Handel EXEC_SELECT_TYPE. 2009-09-30 Janus Weil Paul Thomas * check.c (gfc_check_move_alloc): Arguments don't have to be arrays. The second argument needs to be type-compatible with the first (not the other way around, which makes a difference for CLASS entities). * decl.c (encapsulate_class_symbol): New function. (build_sym,build_struct): Handle BT_CLASS, call 'encapsulate_class_symbol'. (gfc_match_decl_type_spec): Remove warning, use BT_CLASS. (gfc_match_derived_decl): Set vindex; * expr.c (gfc_add_component_ref): New function. (gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol): Handle BT_CLASS. * dump-parse-tree.c (show_symbol): Print vindex. * gfortran.h (bt): New basic type BT_CLASS. (symbol_attribute): New field 'is_class'. (gfc_typespec): Remove field 'is_class'. (gfc_symbol): New field 'vindex'. (gfc_get_ultimate_derived_super_type): New prototype. (gfc_add_component_ref): Ditto. * interface.c (gfc_compare_derived_types): Pointer equality check moved here from gfc_compare_types. (gfc_compare_types): Handle BT_CLASS and use gfc_type_compatible. * match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call): Handle BT_CLASS. * misc.c (gfc_clear_ts): Removed is_class. (gfc_basic_typename,gfc_typename): Handle BT_CLASS. * module.c (bt_types,mio_typespec): Handle BT_CLASS. (mio_symbol): Handle vindex. * primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS. * resolve.c (find_array_spec,check_typebound_baseobject): Handle BT_CLASS. (resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp' inside 'gcc_assert'. (resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS. (check_class_pointer_assign): New function. (resolve_code): Handle BT_CLASS, call check_class_pointer_assign. (resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived, resolve_fl_variable): Handle BT_CLASS. (check_generic_tbp_ambiguity): Add special case. (resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS. * symbol.c (gfc_get_ultimate_derived_super_type): New function. (gfc_type_compatible): Handle BT_CLASS. * trans-expr.c (conv_parent_component_references): Handle CLASS containers. (gfc_conv_initializer): Handle BT_CLASS. * trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type): Handle BT_CLASS. testsuite/ 2009-09-30 Janus Weil * gfortran.dg/same_type_as_1.f03: New test. * gfortran.dg/same_type_as_2.f03: Ditto. 2009-09-30 Janus Weil * gfortran.dg/select_type_1.f03: Extended. * gfortran.dg/select_type_3.f03: New test. 2009-09-30 Janus Weil * gfortran.dg/class_allocate_1.f03: New test. 2009-09-30 Janus Weil PR fortran/40996 * gfortran.dg/allocatable_scalar_3.f90: New test. * gfortran.dg/select_type_2.f03: Ditto. * gfortran.dg/typebound_proc_5.f03: Changed error messages. 2009-09-30 Janus Weil * gfortran.dg/block_name_2.f90: Modified error message. * gfortran.dg/select_6.f90: Ditto. * gfortran.dg/select_type_1.f03: New test. 2009-09-30 Janus Weil * gfortran.dg/allocate_derived_1.f90: Remove -w option. * gfortran.dg/class_1.f03: Ditto. * gfortran.dg/class_2.f03: Ditto. * gfortran.dg/proc_ptr_comp_pass_1.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto. * gfortran.dg/typebound_call_10.f03: Ditto. * gfortran.dg/typebound_call_2.f03: Ditto. * gfortran.dg/typebound_call_3.f03: Ditto. * gfortran.dg/typebound_call_4.f03: Ditto. * gfortran.dg/typebound_call_9.f03: Ditto. * gfortran.dg/typebound_generic_3.f03: Ditto. * gfortran.dg/typebound_generic_4.f03: Ditto. * gfortran.dg/typebound_operator_1.f03: Ditto. * gfortran.dg/typebound_operator_2.f03: Ditto. * gfortran.dg/typebound_operator_3.f03: Ditto. * gfortran.dg/typebound_operator_4.f03: Ditto. * gfortran.dg/typebound_proc_1.f08: Ditto. * gfortran.dg/typebound_proc_5.f03: Ditto. * gfortran.dg/typebound_proc_6.f03: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152345 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 84 ++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 77 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b3642c2232c..eb741f8231f 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -482,7 +482,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) se->string_length = tmp; } - if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER) + if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0 + && c->ts.type != BT_CHARACTER) || c->attr.proc_pointer) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); @@ -510,8 +511,12 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref) if (dt->attr.extension && dt->components) { + if (dt->attr.is_class) + cmp = dt->components; + else + cmp = dt->components->next; /* Return if the component is not in the parent type. */ - for (cmp = dt->components->next; cmp; cmp = cmp->next) + for (; cmp; cmp = cmp->next) if (strcmp (c->name, cmp->name) == 0) return; @@ -2641,6 +2646,49 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); } } + else if (fsym && fsym->ts.type == BT_CLASS + && e->ts.type == BT_DERIVED) + { + tree data; + tree vindex; + + /* The derived type needs to be converted to a temporary + CLASS object. */ + gfc_init_se (&parmse, se); + type = gfc_typenode_for_spec (&fsym->ts); + var = gfc_create_var (type, "class"); + + /* Get the components. */ + tmp = fsym->ts.u.derived->components->backend_decl; + data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), + var, tmp, NULL_TREE); + tmp = fsym->ts.u.derived->components->next->backend_decl; + vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), + var, tmp, NULL_TREE); + + /* Set the vindex. */ + tmp = build_int_cst (TREE_TYPE (vindex), + e->ts.u.derived->vindex); + gfc_add_modify (&parmse.pre, vindex, tmp); + + /* Now set the data field. */ + argss = gfc_walk_expr (e); + if (argss == gfc_ss_terminator) + { + gfc_conv_expr_reference (&parmse, e); + tmp = fold_convert (TREE_TYPE (data), + parmse.expr); + gfc_add_modify (&parmse.pre, data, tmp); + } + else + { + gfc_conv_expr (&parmse, e); + gfc_add_modify (&parmse.pre, data, parmse.expr); + } + + /* Pass the address of the class object. */ + parmse.expr = gfc_build_addr_expr (NULL_TREE, var); + } else if (se->ss && se->ss->useflags) { /* An elemental function inside a scalarized loop. */ @@ -3607,6 +3655,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, switch (ts->type) { case BT_DERIVED: + case BT_CLASS: gfc_init_se (&se, NULL); gfc_conv_structure (&se, expr, 1); return se.expr; @@ -3771,6 +3820,13 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_add_block_to_block (&block, &se.post); } } + else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL) + { + /* NULL initialization for CLASS components. */ + tmp = gfc_trans_structure_assign (dest, + gfc_default_initializer (&cm->ts)); + gfc_add_expr_to_block (&block, tmp); + } else if (cm->attr.dimension) { if (cm->attr.allocatable && expr->expr_type == EXPR_NULL) @@ -3966,12 +4022,26 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!c->expr || cm->attr.allocatable) continue; - val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (cm->backend_decl), cm->attr.dimension, - cm->attr.pointer || cm->attr.proc_pointer); + if (cm->ts.type == BT_CLASS) + { + val = gfc_conv_initializer (c->expr, &cm->ts, + TREE_TYPE (cm->ts.u.derived->components->backend_decl), + cm->ts.u.derived->components->attr.dimension, + cm->ts.u.derived->components->attr.pointer); + + /* Append it to the constructor list. */ + CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl, + val); + } + else + { + val = gfc_conv_initializer (c->expr, &cm->ts, + TREE_TYPE (cm->backend_decl), cm->attr.dimension, + cm->attr.pointer || cm->attr.proc_pointer); - /* Append it to the constructor list. */ - CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + /* Append it to the constructor list. */ + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + } } se->expr = build_constructor (type, v); if (init) -- cgit v1.2.1 From d94c13853accd0d733620f127edb7eb40e4b70b5 Mon Sep 17 00:00:00 2001 From: pault Date: Mon, 5 Oct 2009 18:19:55 +0000 Subject: 2009-10-05 Paul Thomas * trans-expr.c (select_class_proc): New function. (conv_function_val): Deal with class methods and call above. * symbol.c (gfc_type_compatible): Treat case where both ts1 and ts2 are BT_CLASS. gfortran.h : Add structure gfc_class_esym_list and include in the structure gfc_expr. * module.c (load_derived_extensions): New function. (read_module): Call above. (write_dt_extensions): New function. (write_derived_extensions): New function. (write_module): Use the above. * resolve.c (resolve_typebound_call): Add a function expression for class methods. This carries the chain of symbols for the dynamic dispatch in select_class_proc. (resolve_compcall): Add second, boolean argument to indicate if a function is being handled. (check_members): New function. (check_class_members): New function. (resolve_class_compcall): New function. (resolve_class_typebound_call): New function. (gfc_resolve_expr): Call above for component calls.. 2009-10-05 Paul Thomas * gfortran.dg/dynamic_dispatch_1.f90: New test. * gfortran.dg/dynamic_dispatch_2.f90: New test. * gfortran.dg/dynamic_dispatch_3.f90: New test. * gfortran.dg/module_md5_1.f90: Update md5 sum. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152463 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 124 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 124 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index eb741f8231f..77953c8e15f 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1523,11 +1523,135 @@ get_proc_ptr_comp (gfc_expr *e) } +/* Select a class typebound procedure at runtime. */ +static void +select_class_proc (gfc_se *se, gfc_class_esym_list *elist, + tree declared, locus *where) +{ + tree end_label; + tree label; + tree tmp; + tree vindex; + stmtblock_t body; + gfc_class_esym_list *next_elist, *tmp_elist; + + /* Calculate the switch expression: class_object.vindex. */ + gcc_assert (elist->class_object->ts.type == BT_CLASS); + tmp = elist->class_object->ts.u.derived->components->next->backend_decl; + vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), + elist->class_object->backend_decl, + tmp, NULL_TREE); + vindex = gfc_evaluate_now (vindex, &se->pre); + + /* Fix the function type to be that of the declared type. */ + declared = gfc_create_var (TREE_TYPE (declared), "method"); + + end_label = gfc_build_label_decl (NULL_TREE); + + gfc_init_block (&body); + + /* Go through the list of extensions. */ + for (; elist; elist = next_elist) + { + /* This case has already been added. */ + if (elist->derived == NULL) + goto free_elist; + + /* Run through the chain picking up all the cases that call the + same procedure. */ + tmp_elist = elist; + for (; elist; elist = elist->next) + { + tree cval; + + if (elist->esym != tmp_elist->esym) + continue; + + cval = build_int_cst (TREE_TYPE (vindex), + elist->derived->vindex); + /* Build a label for the vindex value. */ + label = gfc_build_label_decl (NULL_TREE); + tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, + cval, NULL_TREE, label); + gfc_add_expr_to_block (&body, tmp); + + /* Null the reference the derived type so that this case is + not used again. */ + elist->derived = NULL; + } + + elist = tmp_elist; + + /* Get a pointer to the procedure, */ + tmp = gfc_get_symbol_decl (elist->esym); + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + { + gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + } + + /* Assign the pointer to the appropriate procedure. */ + gfc_add_modify (&body, declared, + fold_convert (TREE_TYPE (declared), tmp)); + + /* Break to the end of the construct. */ + tmp = build1_v (GOTO_EXPR, end_label); + gfc_add_expr_to_block (&body, tmp); + + /* Free the elists as we go; freeing them in gfc_free_expr causes + segfaults because it occurs too early and too often. */ + free_elist: + next_elist = elist->next; + gfc_free (elist); + elist = NULL; + } + + /* Default is an error. */ + label = gfc_build_label_decl (NULL_TREE); + tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, + NULL_TREE, NULL_TREE, label); + gfc_add_expr_to_block (&body, tmp); + tmp = gfc_trans_runtime_error (true, where, + "internal error: bad vindex in dynamic dispatch"); + gfc_add_expr_to_block (&body, tmp); + + /* Write the switch expression. */ + tmp = gfc_finish_block (&body); + tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE); + gfc_add_expr_to_block (&se->pre, tmp); + + tmp = build1_v (LABEL_EXPR, end_label); + gfc_add_expr_to_block (&se->pre, tmp); + + se->expr = declared; + return; +} + + static void conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tree tmp; + if (expr && expr->symtree + && expr->value.function.class_esym) + { + if (!sym->backend_decl) + sym->backend_decl = gfc_get_extern_function_decl (sym); + + tmp = sym->backend_decl; + + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + { + gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + } + + select_class_proc (se, expr->value.function.class_esym, + tmp, &expr->where); + return; + } + if (gfc_is_proc_ptr_comp (expr, NULL)) tmp = get_proc_ptr_comp (expr); else if (sym->attr.dummy) -- cgit v1.2.1 From 39f3dea01a12406705751179d795b548b7393289 Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 13 Oct 2009 16:12:24 +0000 Subject: 2009-10-13 Janus Weil PR fortran/41581 * decl.c (encapsulate_class_symbol): Add new component '$size'. * resolve.c (resolve_allocate_expr): Move CLASS handling to gfc_trans_allocate. (resolve_class_assign): Replaced by gfc_trans_class_assign. (resolve_code): Remove calls to resolve_class_assign. * trans.c (gfc_trans_code): Use new function gfc_trans_class_assign. * trans-expr.c (get_proc_ptr_comp): Fix a memory leak. (gfc_conv_procedure_call): For CLASS dummies, set the $size component. (gfc_trans_class_assign): New function, replacing resolve_class_assign. * trans-stmt.h (gfc_trans_class_assign): New prototype. * trans-stmt.c (gfc_trans_allocate): Use correct size when allocating CLASS variables. Do proper initialization. Move some code here from resolve_allocate_expr. 2009-10-13 Janus Weil PR fortran/41581 * gfortran.dg/class_allocate_2.f03: Modified. * gfortran.dg/class_allocate_3.f03: New test case. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152715 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 85 ++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 83 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 77953c8e15f..65f13ad8a8d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1519,6 +1519,7 @@ get_proc_ptr_comp (gfc_expr *e) e2 = gfc_copy_expr (e); e2->expr_type = EXPR_VARIABLE; gfc_conv_expr (&comp_se, e2); + gfc_free_expr (e2); return build_fold_addr_expr_loc (input_location, comp_se.expr); } @@ -2775,6 +2776,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tree data; tree vindex; + tree size; /* The derived type needs to be converted to a temporary CLASS object. */ @@ -2788,13 +2790,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, var, tmp, NULL_TREE); tmp = fsym->ts.u.derived->components->next->backend_decl; vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), + var, tmp, NULL_TREE); + tmp = fsym->ts.u.derived->components->next->next->backend_decl; + size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), var, tmp, NULL_TREE); /* Set the vindex. */ - tmp = build_int_cst (TREE_TYPE (vindex), - e->ts.u.derived->vindex); + tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex); gfc_add_modify (&parmse.pre, vindex, tmp); + /* Set the size. */ + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts)); + gfc_add_modify (&parmse.pre, size, + fold_convert (TREE_TYPE (size), tmp)); + /* Now set the data field. */ argss = gfc_walk_expr (e); if (argss == gfc_ss_terminator) @@ -5261,3 +5270,75 @@ gfc_trans_assign (gfc_code * code) { return gfc_trans_assignment (code->expr1, code->expr2, false); } + + +/* Translate an assignment to a CLASS object + (pointer or ordinary assignment). */ + +tree +gfc_trans_class_assign (gfc_code *code) +{ + stmtblock_t block; + tree tmp; + + gfc_start_block (&block); + + if (code->expr2->ts.type != BT_CLASS) + { + /* Insert an additional assignment which sets the '$vindex' field. */ + gfc_expr *lhs,*rhs; + lhs = gfc_copy_expr (code->expr1); + gfc_add_component_ref (lhs, "$vindex"); + if (code->expr2->ts.type == BT_DERIVED) + /* vindex is constant, determined at compile time. */ + rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex); + else if (code->expr2->expr_type == EXPR_NULL) + rhs = gfc_int_expr (0); + else + gcc_unreachable (); + tmp = gfc_trans_assignment (lhs, rhs, false); + gfc_add_expr_to_block (&block, tmp); + + /* Insert another assignment which sets the '$size' field. */ + lhs = gfc_copy_expr (code->expr1); + gfc_add_component_ref (lhs, "$size"); + if (code->expr2->ts.type == BT_DERIVED) + { + /* Size is fixed at compile time. */ + gfc_se lse; + gfc_init_se (&lse, NULL); + gfc_conv_expr (&lse, lhs); + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts)); + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), tmp)); + } + else if (code->expr2->expr_type == EXPR_NULL) + { + rhs = gfc_int_expr (0); + tmp = gfc_trans_assignment (lhs, rhs, false); + gfc_add_expr_to_block (&block, tmp); + } + else + gcc_unreachable (); + + gfc_free_expr (lhs); + gfc_free_expr (rhs); + } + + /* Do the actual CLASS assignment. */ + if (code->expr2->ts.type == BT_CLASS) + code->op = EXEC_ASSIGN; + else + gfc_add_component_ref (code->expr1, "$data"); + + if (code->op == EXEC_ASSIGN) + tmp = gfc_trans_assign (code); + else if (code->op == EXEC_POINTER_ASSIGN) + tmp = gfc_trans_pointer_assign (code); + else + gcc_unreachable(); + + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} -- cgit v1.2.1 From f3f303c6a323d7f3e368018f5bb96950c107dada Mon Sep 17 00:00:00 2001 From: pault Date: Fri, 16 Oct 2009 06:07:09 +0000 Subject: 2009-10-16 Paul Thomas PR fortran/41648 PR fortran/41656 * trans-expr.c (select_class_proc): Convert the expression for the vindex, carried on the first member of the esym list. * gfortran.h : Add the vindex field to the esym_list structure. and eliminate the class_object field. * resolve.c (check_class_members): Remove the setting of the class_object field. (vindex_expr): New function. (get_class_from_expr): New function. (resolve_class_compcall): Call the above to find the ultimate class or derived component. If derived, do not generate the esym list. Add and expression for the vindex to the esym list by calling the above. (resolve_class_typebound_call): The same. 2009-10-16 Paul Thomas PR fortran/41648 * gfortran.dg/dynamic_dispatch_4.f03 : New test. PR fortran/41656 * gfortran.dg/dynamic_dispatch_5.f03 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152890 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 65f13ad8a8d..331ca6a4ee4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1527,7 +1527,7 @@ get_proc_ptr_comp (gfc_expr *e) /* Select a class typebound procedure at runtime. */ static void select_class_proc (gfc_se *se, gfc_class_esym_list *elist, - tree declared, locus *where) + tree declared, gfc_expr *expr) { tree end_label; tree label; @@ -1535,16 +1535,16 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, tree vindex; stmtblock_t body; gfc_class_esym_list *next_elist, *tmp_elist; + gfc_se tmpse; - /* Calculate the switch expression: class_object.vindex. */ - gcc_assert (elist->class_object->ts.type == BT_CLASS); - tmp = elist->class_object->ts.u.derived->components->next->backend_decl; - vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - elist->class_object->backend_decl, - tmp, NULL_TREE); - vindex = gfc_evaluate_now (vindex, &se->pre); + /* Convert the vindex expression. */ + gfc_init_se (&tmpse, NULL); + gfc_conv_expr (&tmpse, elist->vindex); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + vindex = gfc_evaluate_now (tmpse.expr, &se->pre); + gfc_add_block_to_block (&se->post, &tmpse.post); - /* Fix the function type to be that of the declared type. */ + /* Fix the function type to be that of the declared type method. */ declared = gfc_create_var (TREE_TYPE (declared), "method"); end_label = gfc_build_label_decl (NULL_TREE); @@ -1603,6 +1603,8 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, segfaults because it occurs too early and too often. */ free_elist: next_elist = elist->next; + if (elist->vindex) + gfc_free_expr (elist->vindex); gfc_free (elist); elist = NULL; } @@ -1612,7 +1614,7 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, NULL_TREE, NULL_TREE, label); gfc_add_expr_to_block (&body, tmp); - tmp = gfc_trans_runtime_error (true, where, + tmp = gfc_trans_runtime_error (true, &expr->where, "internal error: bad vindex in dynamic dispatch"); gfc_add_expr_to_block (&body, tmp); @@ -1649,7 +1651,7 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) } select_class_proc (se, expr->value.function.class_esym, - tmp, &expr->where); + tmp, expr); return; } -- cgit v1.2.1 From 49974242dec99668e56218c0962918cf49c8cc4e Mon Sep 17 00:00:00 2001 From: rguenth Date: Mon, 19 Oct 2009 08:45:43 +0000 Subject: 2009-10-18 Richard Guenther PR fortran/41494 * trans-expr.c (gfc_trans_scalar_assign): Do not call gfc_evaluate_now. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152973 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 331ca6a4ee4..dc58dbf943d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4664,8 +4664,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, { gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); - tmp = gfc_evaluate_now (rse->expr, &block); - tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), tmp); + tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr); gfc_add_modify (&block, lse->expr, tmp); } else -- cgit v1.2.1 From 15f8087142b144a4c273faacad1b9fcb2cbf73c2 Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 23 Oct 2009 16:10:08 +0000 Subject: 2009-10-23 Janus Weil PR fortran/41800 * trans-expr.c (gfc_trans_scalar_assign): Handle CLASS variables. 2009-10-23 Janus Weil PR fortran/41800 * gfortran.dg/class_10.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153504 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index dc58dbf943d..da442edba4b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4660,7 +4660,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_expr_to_block (&block, tmp); } } - else if (ts.type == BT_DERIVED) + else if (ts.type == BT_DERIVED || ts.type == BT_CLASS) { gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); -- cgit v1.2.1 From 7035e05707c314e5d76d25386cf4cf6a4d06f4d5 Mon Sep 17 00:00:00 2001 From: burnus Date: Thu, 29 Oct 2009 15:24:38 +0000 Subject: 2009-10-29 Tobias Burnus PR fortran/41777 * trans-expr.c * (gfc_conv_procedure_call,gfc_conv_expr_reference): Use for generic EXPR_FUNCTION the attributes of the specific function. 2009-10-29 Tobias Burnus PR fortran/41777 gfortran.dg/associated_target_3.f90: New testcase. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153706 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index da442edba4b..7eddbd4e28a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2870,8 +2870,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, through arg->name. */ conv_arglist_function (&parmse, arg->expr, arg->name); else if ((e->expr_type == EXPR_FUNCTION) - && e->symtree->n.sym->attr.pointer - && fsym && fsym->attr.target) + && ((e->value.function.esym + && e->value.function.esym->result->attr.pointer) + || (!e->value.function.esym + && e->symtree->n.sym->attr.pointer)) + && fsym && fsym->attr.target) { gfc_conv_expr (&parmse, e); parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); @@ -4368,8 +4371,12 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) } if (expr->expr_type == EXPR_FUNCTION - && expr->symtree->n.sym->attr.pointer - && !expr->symtree->n.sym->attr.dimension) + && ((expr->value.function.esym + && expr->value.function.esym->result->attr.pointer + && !expr->value.function.esym->result->attr.dimension) + || (!expr->value.function.esym + && expr->symtree->n.sym->attr.pointer + && !expr->symtree->n.sym->attr.dimension))) { se->want_pointer = 1; gfc_conv_expr (se, expr); -- cgit v1.2.1 From d99419eb0cd86223baeb9d06d528cfda2cbcd1b0 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 1 Nov 2009 12:43:42 +0000 Subject: 2009-11-01 Tobias Burnus PR fortran/41850 * trans-expr.c (gfc_conv_procedure_call): Deallocate intent-out variables only when present. Remove unneccessary present check. 2009-11-01 Tobias Burnus PR fortran/41850 * gfortran.dg/intent_out_6.f90: New testcase. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153793 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 42 +++++++++++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 13 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7eddbd4e28a..8255bb1aea5 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2935,17 +2935,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_array_parameter (&parmse, e, argss, f, fsym, sym->name, NULL); - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is - allocated on entry, it must be deallocated. */ - if (fsym && fsym->attr.allocatable - && fsym->attr.intent == INTENT_OUT) - { - tmp = build_fold_indirect_ref_loc (input_location, - parmse.expr); - tmp = gfc_trans_dealloc_allocated (tmp); - gfc_add_expr_to_block (&se->pre, tmp); - } - + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + allocated on entry, it must be deallocated. */ + if (fsym && fsym->attr.allocatable + && fsym->attr.intent == INTENT_OUT) + { + tmp = build_fold_indirect_ref_loc (input_location, + parmse.expr); + tmp = gfc_trans_dealloc_allocated (tmp); + if (fsym->attr.optional + && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + tmp = fold_build3 (COND_EXPR, void_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->pre, tmp); + } } } @@ -2957,9 +2962,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (e && (fsym == NULL || fsym->attr.optional)) { /* If an optional argument is itself an optional dummy argument, - check its presence and substitute a null if absent. */ + check its presence and substitute a null if absent. This is + only needed when passing an array to an elemental procedure + as then array elements are accessed - or no NULL pointer is + allowed and a "1" or "0" should be passed if not present. + When passing a deferred array to a non-deferred array dummy, + the array needs to be packed and a check needs thus to be + inserted. */ if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.optional) + && e->symtree->n.sym->attr.optional + && ((e->rank > 0 && sym->attr.elemental) + || e->representation.length || e->ts.type == BT_CHARACTER + || (e->rank > 0 && (fsym == NULL + || (fsym->as->type != AS_ASSUMED_SHAPE + && fsym->as->type != AS_DEFERRED))))) gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts, e->representation.length); } -- cgit v1.2.1 From 5176859a917209dc5320a6f25a1cc5badb3a4320 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 1 Nov 2009 17:46:50 +0000 Subject: 2009-11-01 Tobias Burnus PR fortran/41872 * trans-decl.c (gfc_trans_deferred_vars): Do not nullify autodeallocated allocatable scalars at the end of scope. (gfc_generate_function_code): Fix indention. * trans-expr.c (gfc_conv_procedure_call): For allocatable scalars, fix calling by reference and autodeallocating of intent out variables. 2009-11-01 Tobias Burnus PR fortran/41872 * gfortran.dg/allocatable_scalar_4.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153795 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 36 ++++++++++++++++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 8255bb1aea5..d8f8303fdbd 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2892,6 +2892,37 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else { gfc_conv_expr_reference (&parmse, e); + + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + allocated on entry, it must be deallocated. */ + if (fsym && fsym->attr.allocatable + && fsym->attr.intent == INTENT_OUT) + { + stmtblock_t block; + + gfc_init_block (&block); + tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE, + true, NULL); + gfc_add_expr_to_block (&block, tmp); + tmp = fold_build2 (MODIFY_EXPR, void_type_node, + parmse.expr, null_pointer_node); + gfc_add_expr_to_block (&block, tmp); + + if (fsym->attr.optional + && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + { + tmp = fold_build3 (COND_EXPR, void_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + gfc_finish_block (&block), + build_empty_stmt (input_location)); + } + else + tmp = gfc_finish_block (&block); + + gfc_add_expr_to_block (&se->pre, tmp); + } + if (fsym && e->expr_type != EXPR_NULL && ((fsym->attr.pointer && fsym->attr.flavor != FL_PROCEDURE) @@ -2899,7 +2930,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && !(e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)) || (e->expr_type == EXPR_VARIABLE - && gfc_is_proc_ptr_comp (e, NULL)))) + && gfc_is_proc_ptr_comp (e, NULL)) + || fsym->attr.allocatable)) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains @@ -3169,7 +3201,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, cl.backend_decl = formal->sym->ts.u.cl->backend_decl; } } - else + else { tree tmp; -- cgit v1.2.1 From b460b38698c7a2c2126250dec94f40a636635a66 Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 3 Nov 2009 16:51:52 +0000 Subject: 2009-11-03 Tobias Burnus PR fortran/41907 * trans-expr.c (gfc_conv_procedure_call): Fix presence check for optional arguments. 2009-11-03 Tobias Burnus PR fortran/41907 * gfortran.dg/missing_optional_dummy_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153854 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d8f8303fdbd..5a45f4f6368 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2998,16 +2998,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, only needed when passing an array to an elemental procedure as then array elements are accessed - or no NULL pointer is allowed and a "1" or "0" should be passed if not present. - When passing a deferred array to a non-deferred array dummy, - the array needs to be packed and a check needs thus to be - inserted. */ + When passing a non-array-descriptor full array to a + non-array-descriptor dummy, no check is needed. For + array-descriptor actual to array-descriptor dummy, see + PR 41911 for why a check has to be inserted. + fsym == NULL is checked as intrinsics required the descriptor + but do not always set fsym. */ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional && ((e->rank > 0 && sym->attr.elemental) || e->representation.length || e->ts.type == BT_CHARACTER - || (e->rank > 0 && (fsym == NULL - || (fsym->as->type != AS_ASSUMED_SHAPE - && fsym->as->type != AS_DEFERRED))))) + || (e->rank > 0 + && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE + || fsym->as->type == AS_DEFERRED)))) gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts, e->representation.length); } -- cgit v1.2.1 From 19b7a51ee94ca58ab1f8c58ccc1cc6f390c3c377 Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 18 Nov 2009 13:24:54 +0000 Subject: 2009-11-18 Janus Weil PR fortran/42072 * trans-expr.c (gfc_conv_procedure_call): Handle procedure pointer dummies which are passed to C_F_PROCPOINTER. 2009-11-18 Janus Weil PR fortran/42072 * gfortran.dg/proc_ptr_8.f90: Extended. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154292 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 5a45f4f6368..b72d5401bae 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2640,13 +2640,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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 (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); - se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr, - fold_convert (tmp, cptrse.expr)); + + if (arg->next->expr->symtree->n.sym->attr.proc_pointer + && arg->next->expr->symtree->n.sym->attr.dummy) + fptrse.expr = build_fold_indirect_ref_loc (input_location, + fptrse.expr); + + se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr), + fptrse.expr, + fold_convert (TREE_TYPE (fptrse.expr), + cptrse.expr)); return 0; } -- cgit v1.2.1 From 8bedd8d9e4f65aec8382c82eddb88c7658053ebf Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 19 Nov 2009 10:29:41 +0000 Subject: 2009-11-19 Janus Weil * trans-expr.c (conv_isocbinding_procedure): New function. (gfc_conv_procedure_call): Move ISO_C_BINDING stuff to separate function. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154327 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 271 +++++++++++++++++++++++++---------------------- 1 file changed, 147 insertions(+), 124 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b72d5401bae..c0df6782750 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2533,6 +2533,150 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) } +/* The following routine generates code for the intrinsic + procedures from the ISO_C_BINDING module: + * C_LOC (function) + * C_FUNLOC (function) + * C_F_POINTER (subroutine) + * C_F_PROCPOINTER (subroutine) + * C_ASSOCIATED (function) + One exception which is not handled here is C_F_POINTER with non-scalar + arguments. Returns 1 if the call was replaced by inline code (else: 0). */ + +static int +conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, + gfc_actual_arglist * arg) +{ + gfc_symbol *fsym; + gfc_ss *argss; + + if (sym->intmod_sym_id == ISOCBINDING_LOC) + { + if (arg->expr->rank == 0) + gfc_conv_expr_reference (se, arg->expr); + else + { + int f; + /* This is really the actual arg because no formal arglist is + created for C_LOC. */ + fsym = arg->expr->symtree->n.sym; + + /* We should want it to do g77 calling convention. */ + f = (fsym != NULL) + && !(fsym->attr.pointer || fsym->attr.allocatable) + && fsym->as->type != AS_ASSUMED_SHAPE; + f = f || !sym->attr.always_explicit; + + argss = gfc_walk_expr (arg->expr); + gfc_conv_array_parameter (se, arg->expr, argss, f, + NULL, NULL, NULL); + } + + /* TODO -- the following two lines shouldn't be necessary, but if + they're removed, a bug is exposed later in the code path. + This workaround was thus introduced, but will have to be + removed; please see PR 35150 for details about the issue. */ + se->expr = convert (pvoid_type_node, se->expr); + se->expr = gfc_evaluate_now (se->expr, &se->pre); + + return 1; + } + else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC) + { + arg->expr->ts.type = sym->ts.u.derived->ts.type; + arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type; + arg->expr->ts.kind = sym->ts.u.derived->ts.kind; + gfc_conv_expr_reference (se, arg->expr); + + return 1; + } + else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER + && arg->next->expr->rank == 0) + || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER) + { + /* Convert c_f_pointer if fptr is a scalar + and convert c_f_procpointer. */ + gfc_se cptrse; + gfc_se fptrse; + + gfc_init_se (&cptrse, NULL); + gfc_conv_expr (&cptrse, arg->expr); + gfc_add_block_to_block (&se->pre, &cptrse.pre); + gfc_add_block_to_block (&se->post, &cptrse.post); + + gfc_init_se (&fptrse, NULL); + if (sym->intmod_sym_id == ISOCBINDING_F_POINTER + || 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 (arg->next->expr->symtree->n.sym->attr.proc_pointer + && arg->next->expr->symtree->n.sym->attr.dummy) + fptrse.expr = build_fold_indirect_ref_loc (input_location, + fptrse.expr); + + se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr), + fptrse.expr, + fold_convert (TREE_TYPE (fptrse.expr), + cptrse.expr)); + + return 1; + } + else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) + { + gfc_se arg1se; + gfc_se arg2se; + + /* Build the addr_expr for the first argument. The argument is + already an *address* so we don't need to set want_pointer in + the gfc_se. */ + gfc_init_se (&arg1se, NULL); + gfc_conv_expr (&arg1se, arg->expr); + gfc_add_block_to_block (&se->pre, &arg1se.pre); + gfc_add_block_to_block (&se->post, &arg1se.post); + + /* See if we were given two arguments. */ + if (arg->next == NULL) + /* Only given one arg so generate a null and do a + not-equal comparison against the first arg. */ + se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr, + fold_convert (TREE_TYPE (arg1se.expr), + null_pointer_node)); + else + { + tree eq_expr; + tree not_null_expr; + + /* Given two arguments so build the arg2se from second arg. */ + gfc_init_se (&arg2se, NULL); + gfc_conv_expr (&arg2se, arg->next->expr); + gfc_add_block_to_block (&se->pre, &arg2se.pre); + gfc_add_block_to_block (&se->post, &arg2se.post); + + /* Generate test to compare that the two args are equal. */ + eq_expr = fold_build2 (EQ_EXPR, boolean_type_node, + arg1se.expr, arg2se.expr); + /* Generate test to ensure that the first arg is not null. */ + not_null_expr = fold_build2 (NE_EXPR, boolean_type_node, + arg1se.expr, null_pointer_node); + + /* Finally, the generated test must check that both arg1 is not + NULL and that it is equal to the second arg. */ + se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, + not_null_expr, eq_expr); + } + + return 1; + } + + /* Nothing was done. */ + return 0; +} + + /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -2576,130 +2720,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, len = NULL_TREE; gfc_clear_ts (&ts); - if (sym->from_intmod == INTMOD_ISO_C_BINDING) - { - if (sym->intmod_sym_id == ISOCBINDING_LOC) - { - if (arg->expr->rank == 0) - gfc_conv_expr_reference (se, arg->expr); - else - { - int f; - /* This is really the actual arg because no formal arglist is - created for C_LOC. */ - fsym = arg->expr->symtree->n.sym; - - /* We should want it to do g77 calling convention. */ - f = (fsym != NULL) - && !(fsym->attr.pointer || fsym->attr.allocatable) - && fsym->as->type != AS_ASSUMED_SHAPE; - f = f || !sym->attr.always_explicit; - - argss = gfc_walk_expr (arg->expr); - gfc_conv_array_parameter (se, arg->expr, argss, f, - NULL, NULL, NULL); - } - - /* TODO -- the following two lines shouldn't be necessary, but - they're removed a bug is exposed later in the codepath. - This is workaround was thus introduced, but will have to be - removed; please see PR 35150 for details about the issue. */ - se->expr = convert (pvoid_type_node, se->expr); - se->expr = gfc_evaluate_now (se->expr, &se->pre); - - return 0; - } - else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC) - { - arg->expr->ts.type = sym->ts.u.derived->ts.type; - arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type; - arg->expr->ts.kind = sym->ts.u.derived->ts.kind; - gfc_conv_expr_reference (se, arg->expr); - - return 0; - } - else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER - && arg->next->expr->rank == 0) - || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER) - { - /* Convert c_f_pointer if fptr is a scalar - and convert c_f_procpointer. */ - gfc_se cptrse; - gfc_se fptrse; - - gfc_init_se (&cptrse, NULL); - gfc_conv_expr (&cptrse, arg->expr); - gfc_add_block_to_block (&se->pre, &cptrse.pre); - gfc_add_block_to_block (&se->post, &cptrse.post); - - gfc_init_se (&fptrse, NULL); - if (sym->intmod_sym_id == ISOCBINDING_F_POINTER - || 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 (arg->next->expr->symtree->n.sym->attr.proc_pointer - && arg->next->expr->symtree->n.sym->attr.dummy) - fptrse.expr = build_fold_indirect_ref_loc (input_location, - fptrse.expr); - - se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr), - fptrse.expr, - fold_convert (TREE_TYPE (fptrse.expr), - cptrse.expr)); - - return 0; - } - else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) - { - gfc_se arg1se; - gfc_se arg2se; - - /* Build the addr_expr for the first argument. The argument is - already an *address* so we don't need to set want_pointer in - the gfc_se. */ - gfc_init_se (&arg1se, NULL); - gfc_conv_expr (&arg1se, arg->expr); - gfc_add_block_to_block (&se->pre, &arg1se.pre); - gfc_add_block_to_block (&se->post, &arg1se.post); - - /* See if we were given two arguments. */ - if (arg->next == NULL) - /* Only given one arg so generate a null and do a - not-equal comparison against the first arg. */ - se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr, - fold_convert (TREE_TYPE (arg1se.expr), - null_pointer_node)); - else - { - tree eq_expr; - tree not_null_expr; - - /* Given two arguments so build the arg2se from second arg. */ - gfc_init_se (&arg2se, NULL); - gfc_conv_expr (&arg2se, arg->next->expr); - gfc_add_block_to_block (&se->pre, &arg2se.pre); - gfc_add_block_to_block (&se->post, &arg2se.post); - - /* Generate test to compare that the two args are equal. */ - eq_expr = fold_build2 (EQ_EXPR, boolean_type_node, - arg1se.expr, arg2se.expr); - /* Generate test to ensure that the first arg is not null. */ - not_null_expr = fold_build2 (NE_EXPR, boolean_type_node, - arg1se.expr, null_pointer_node); - - /* Finally, the generated test must check that both arg1 is not - NULL and that it is equal to the second arg. */ - se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - not_null_expr, eq_expr); - } - - return 0; - } - } + if (sym->from_intmod == INTMOD_ISO_C_BINDING + && conv_isocbinding_procedure (se, sym, arg)) + return 0; gfc_is_proc_ptr_comp (expr, &comp); -- cgit v1.2.1 From 7e74cd03929534bffbd67ea492b1d168329ff5ff Mon Sep 17 00:00:00 2001 From: pault Date: Fri, 20 Nov 2009 06:43:13 +0000 Subject: 2009-11-20 Paul Thomas Janus Weil PR fortran/42104 * trans-expr.c (gfc_conv_procedure_call): If procedure pointer component call, use the component's 'always_explicit' attr for array arguments. 2009-11-20 Paul Thomas Janus Weil PR fortran/42104 * gfortran.dg/proc_ptr_comp_23.f90 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154358 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index c0df6782750..6646b266a6d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2979,7 +2979,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, f = (fsym != NULL) && !(fsym->attr.pointer || fsym->attr.allocatable) && fsym->as->type != AS_ASSUMED_SHAPE; - f = f || !sym->attr.always_explicit; + if (comp) + f = f || !comp->attr.always_explicit; + else + f = f || !sym->attr.always_explicit; if (e->expr_type == EXPR_VARIABLE && is_subref_array (e)) -- cgit v1.2.1 From 66a56860076243903465dadec8482f55d32144dc Mon Sep 17 00:00:00 2001 From: jakub Date: Sat, 28 Nov 2009 12:13:21 +0000 Subject: * trans-common.c (create_common): Remove unused offset variable. * io.c (gfc_match_wait): Remove unused loc variable. * trans-openmp.c (gfc_trans_omp_clauses): Remove unused old_clauses variable. (gfc_trans_omp_do): Remove unused outermost variable. * iresolve.c (gfc_resolve_alarm_sub, gfc_resolve_fseek_sub): Remove unused status variable. * module.c (number_use_names): Remove unused c variable. (load_derived_extensions): Remove unused nuse variable. * trans-expr.c (gfc_conv_substring): Remove unused var variable. * trans-types.c (gfc_get_array_descr_info): Remove unused offset_off variable. * matchexp.c (match_primary): Remove unused where variable. * trans-intrinsic.c (gfc_conv_intrinsic_bound): Remove unused cond2 variable. (gfc_conv_intrinsic_sizeof): Remove unused source variable. (gfc_conv_intrinsic_transfer): Remove unused stride variable. (gfc_conv_intrinsic_function): Remove unused isym variable. * arith.c (gfc_hollerith2real, gfc_hollerith2complex, gfc_hollerith2logical): Remove unused len variable. * parse.c (parse_derived): Remove unused derived_sym variable. * decl.c (variable_decl): Remove unused old_locus variable. * resolve.c (check_class_members): Remove unused tbp_sym variable. (resolve_ordinary_assign): Remove unused assign_proc variable. (resolve_equivalence): Remove unused value_name variable. * data.c (get_array_index): Remove unused re variable. * trans-array.c (gfc_conv_array_transpose): Remove unused src_info variable. (gfc_conv_resolve_dependencies): Remove unused aref and temp_dim variables. (gfc_conv_loop_setup): Remove unused dim and len variables. (gfc_walk_variable_expr): Remove unused head variable. * match.c (match_typebound_call): Remove unused var variable. * intrinsic.c (gfc_convert_chartype): Remove unused from_ts variable. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154722 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 2 -- 1 file changed, 2 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6646b266a6d..77de6bd5773 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -356,7 +356,6 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, { tree tmp; tree type; - tree var; tree fault; gfc_se start; gfc_se end; @@ -365,7 +364,6 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, type = gfc_get_character_type (kind, ref->u.ss.length); type = build_pointer_type (type); - var = NULL_TREE; gfc_init_se (&start, se); gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node); gfc_add_block_to_block (&se->pre, &start.pre); -- cgit v1.2.1 From bdfbc762ef80b1196e214ed9c90e9f57a11e264b Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 30 Nov 2009 20:43:06 +0000 Subject: merge from fortran-dev branch: gcc/fortran/ 2009-11-30 Janus Weil PR fortran/42053 * resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks. 2009-11-30 Janus Weil PR fortran/41631 * decl.c (gfc_match_derived_decl): Set extension level. * gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit. * iresolve.c (gfc_resolve_extends_type_of): Return value of 'is_extension_of' has kind=4. * match.c (select_type_set_tmp,gfc_match_class_is): Create temporary for CLASS IS blocks. * module.c (MOD_VERSION): Bump module version. (ab_attribute,attr_bits): Remove AB_EXTENSION. (mio_symbol_attribute): Handle expanded 'extension' field. * resolve.c (resolve_select_type): Implement CLASS IS blocks. (resolve_fl_variable_derived): Show correct type name. * symbol.c (gfc_build_class_symbol): Set extension level. 2009-11-30 Janus Weil * intrinsic.h (gfc_resolve_extends_type_of): Add prototype. * intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'. * iresolve.c (gfc_resolve_extends_type_of): New function, which replaces the call to EXTENDS_TYPE_OF by the library function 'is_extension_of' and modifies the arguments. * trans-intrinsic.c (gfc_conv_extends_type_of): Removed. (gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall. 2009-11-30 Paul Thomas Janus Weil * decl.c (encapsulate_class_symbol): Replaced by 'gfc_build_class_symbol'. (build_sym,build_struct): Call 'gfc_build_class_symbol'. (gfc_match_derived_decl): Replace vindex by hash_value. * dump-parse-tree.c (show_symbol): Replace vindex by hash_value. * gfortran.h (symbol_attribute): Add field 'vtab'. (gfc_symbol): Replace vindex by hash_value. (gfc_class_esym_list): Ditto. (gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab): New prototypes. * module.c (mio_symbol): Replace vindex by hash_value. * resolve.c (vindex_expr): Rename to 'hash_value_expr'. (resolve_class_compcall,resolve_class_typebound_call): Renamed 'vindex_expr'. (resolve_select_type): Replace $vindex by $vptr->$hash. * symbol.c (gfc_add_save): Handle vtab symbols. (gfc_type_compatible): Rewrite. (gfc_build_class_symbol): New function which replaces 'encapsulate_class_symbol'. (gfc_find_derived_vtab): New function to set up a vtab symbol for a derived type. * trans-decl.c (gfc_create_module_variable): Handle vtab symbols. * trans-expr.c (select_class_proc): Replace vindex by hash_value. (gfc_conv_derived_to_class): New function to construct a temporary CLASS variable from a derived type expression. (gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'. (gfc_conv_structure): Initialize the $extends and $size fields of vtab symbols. (gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size assignment. * trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by $vptr->$hash, and replace vindex by hash_value. * trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace $vindex by $vptr. Remove the $size assignment. * trans-types.c (gfc_get_derived_type): Make it non-static. gcc/testsuite/ 2009-11-30 Janus Weil PR fortran/42053 * gfortran.dg/select_type_9.f03: New. 2009-11-30 Janus Weil PR fortran/41631 * gfortran.dg/extends_type_of_1.f03: Fix invalid test case. * gfortran.dg/module_md5_1.f90: Adjusted MD5 sum. * gfortran.dg/select_type_1.f03: Remove FIXMEs. * gfortran.dg/select_type_2.f03: Ditto. * gfortran.dg/select_type_8.f03: New test. 2009-11-30 Janus Weil * gfortran.dg/extends_type_of_1.f03: New test. * gfortran.dg/same_type_as_1.f03: Extended. 2009-11-30 Paul Thomas * gfortran.dg/class_4c.f03: Add dg-additional-sources. * gfortran.dg/class_4d.f03: Rename module. Cleanup modules. libgfortran/ 2009-11-30 Janus Weil * gfortran.map: Add _gfortran_is_extension_of. * Makefile.am: Add intrinsics/extends_type_of.c. * Makefile.in: Regenerated. * intrinsics/extends_type_of.c: New file. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154840 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 192 +++++++++++++++++++++++++---------------------- 1 file changed, 103 insertions(+), 89 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 77de6bd5773..acca306a2ff 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1530,16 +1530,16 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, tree end_label; tree label; tree tmp; - tree vindex; + tree hash; stmtblock_t body; gfc_class_esym_list *next_elist, *tmp_elist; gfc_se tmpse; - /* Convert the vindex expression. */ + /* Convert the hash expression. */ gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, elist->vindex); + gfc_conv_expr (&tmpse, elist->hash_value); gfc_add_block_to_block (&se->pre, &tmpse.pre); - vindex = gfc_evaluate_now (tmpse.expr, &se->pre); + hash = gfc_evaluate_now (tmpse.expr, &se->pre); gfc_add_block_to_block (&se->post, &tmpse.post); /* Fix the function type to be that of the declared type method. */ @@ -1566,9 +1566,9 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, if (elist->esym != tmp_elist->esym) continue; - cval = build_int_cst (TREE_TYPE (vindex), - elist->derived->vindex); - /* Build a label for the vindex value. */ + cval = build_int_cst (TREE_TYPE (hash), + elist->derived->hash_value); + /* Build a label for the hash value. */ label = gfc_build_label_decl (NULL_TREE); tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, cval, NULL_TREE, label); @@ -1601,8 +1601,8 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, segfaults because it occurs too early and too often. */ free_elist: next_elist = elist->next; - if (elist->vindex) - gfc_free_expr (elist->vindex); + if (elist->hash_value) + gfc_free_expr (elist->hash_value); gfc_free (elist); elist = NULL; } @@ -1613,12 +1613,12 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, NULL_TREE, NULL_TREE, label); gfc_add_expr_to_block (&body, tmp); tmp = gfc_trans_runtime_error (true, &expr->where, - "internal error: bad vindex in dynamic dispatch"); + "internal error: bad hash value in dynamic dispatch"); gfc_add_expr_to_block (&body, tmp); /* Write the switch expression. */ tmp = gfc_finish_block (&body); - tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE); + tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE); gfc_add_expr_to_block (&se->pre, tmp); tmp = build1_v (LABEL_EXPR, end_label); @@ -2531,6 +2531,60 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) } +/* Takes a derived type expression and returns the address of a temporary + class object of the 'declared' type. */ +static void +gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, + gfc_typespec class_ts) +{ + gfc_component *cmp; + gfc_symbol *vtab; + gfc_symbol *declared = class_ts.u.derived; + gfc_ss *ss; + tree ctree; + tree var; + tree tmp; + + /* The derived type needs to be converted to a temporary + CLASS object. */ + tmp = gfc_typenode_for_spec (&class_ts); + var = gfc_create_var (tmp, "class"); + + /* Set the vptr. */ + cmp = gfc_find_component (declared, "$vptr", true, true); + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); + + /* Remember the vtab corresponds to the derived type + not to the class declared type. */ + vtab = gfc_find_derived_vtab (e->ts.u.derived); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), tmp)); + + /* Now set the data field. */ + cmp = gfc_find_component (declared, "$data", true, true); + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); + ss = gfc_walk_expr (e); + if (ss == gfc_ss_terminator) + { + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + gfc_conv_expr (parmse, e); + gfc_add_modify (&parmse->pre, ctree, parmse->expr); + } + + /* Pass the address of the class object. */ + parmse->expr = gfc_build_addr_expr (NULL_TREE, var); +} + + /* The following routine generates code for the intrinsic procedures from the ISO_C_BINDING module: * C_LOC (function) @@ -2800,53 +2854,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_DERIVED) { - tree data; - tree vindex; - tree size; - /* The derived type needs to be converted to a temporary CLASS object. */ gfc_init_se (&parmse, se); - type = gfc_typenode_for_spec (&fsym->ts); - var = gfc_create_var (type, "class"); - - /* Get the components. */ - tmp = fsym->ts.u.derived->components->backend_decl; - data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - var, tmp, NULL_TREE); - tmp = fsym->ts.u.derived->components->next->backend_decl; - vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - var, tmp, NULL_TREE); - tmp = fsym->ts.u.derived->components->next->next->backend_decl; - size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - var, tmp, NULL_TREE); - - /* Set the vindex. */ - tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex); - gfc_add_modify (&parmse.pre, vindex, tmp); - - /* Set the size. */ - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts)); - gfc_add_modify (&parmse.pre, size, - fold_convert (TREE_TYPE (size), tmp)); - - /* Now set the data field. */ - argss = gfc_walk_expr (e); - if (argss == gfc_ss_terminator) - { - gfc_conv_expr_reference (&parmse, e); - tmp = fold_convert (TREE_TYPE (data), - parmse.expr); - gfc_add_modify (&parmse.pre, data, tmp); - } - else - { - gfc_conv_expr (&parmse, e); - gfc_add_modify (&parmse.pre, data, parmse.expr); - } - - /* Pass the address of the class object. */ - parmse.expr = gfc_build_addr_expr (NULL_TREE, var); + gfc_conv_derived_to_class (&parmse, e, fsym->ts); } else if (se->ss && se->ss->useflags) { @@ -4240,14 +4251,27 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (cm->ts.type == BT_CLASS) { + gfc_component *data; + data = gfc_find_component (cm->ts.u.derived, "$data", true, true); val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (cm->ts.u.derived->components->backend_decl), - cm->ts.u.derived->components->attr.dimension, - cm->ts.u.derived->components->attr.pointer); + TREE_TYPE (data->backend_decl), + data->attr.dimension, + data->attr.pointer); - /* Append it to the constructor list. */ - CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl, - val); + CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val); + } + else if (strcmp (cm->name, "$size") == 0) + { + val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + } + else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL + && strcmp (cm->name, "$extends") == 0) + { + gfc_symbol *vtabs; + vtabs = cm->initializer->symtree->n.sym; + val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); } else { @@ -5366,47 +5390,37 @@ gfc_trans_class_assign (gfc_code *code) { stmtblock_t block; tree tmp; + gfc_expr *lhs; + gfc_expr *rhs; gfc_start_block (&block); if (code->expr2->ts.type != BT_CLASS) { - /* Insert an additional assignment which sets the '$vindex' field. */ - gfc_expr *lhs,*rhs; + /* Insert an additional assignment which sets the '$vptr' field. */ lhs = gfc_copy_expr (code->expr1); - gfc_add_component_ref (lhs, "$vindex"); - if (code->expr2->ts.type == BT_DERIVED) - /* vindex is constant, determined at compile time. */ - rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex); - else if (code->expr2->expr_type == EXPR_NULL) - rhs = gfc_int_expr (0); - else - gcc_unreachable (); - tmp = gfc_trans_assignment (lhs, rhs, false); - gfc_add_expr_to_block (&block, tmp); - - /* Insert another assignment which sets the '$size' field. */ - lhs = gfc_copy_expr (code->expr1); - gfc_add_component_ref (lhs, "$size"); + gfc_add_component_ref (lhs, "$vptr"); if (code->expr2->ts.type == BT_DERIVED) { - /* Size is fixed at compile time. */ - gfc_se lse; - gfc_init_se (&lse, NULL); - gfc_conv_expr (&lse, lhs); - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts)); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), tmp)); + gfc_symbol *vtab; + gfc_symtree *st; + vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived); + gcc_assert (vtab); + + rhs = gfc_get_expr (); + rhs->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (vtab->name, NULL, 1, &st); + rhs->symtree = st; + rhs->ts = vtab->ts; } else if (code->expr2->expr_type == EXPR_NULL) - { - rhs = gfc_int_expr (0); - tmp = gfc_trans_assignment (lhs, rhs, false); - gfc_add_expr_to_block (&block, tmp); - } + rhs = gfc_int_expr (0); else gcc_unreachable (); + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + gfc_free_expr (lhs); gfc_free_expr (rhs); } -- cgit v1.2.1 From 70f8819676f66962e8ff78de9ba9649388da2cd2 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 17 Dec 2009 09:28:25 +0000 Subject: gcc/fortran/ 2009-12-17 Janus Weil PR fortran/42144 * trans-expr.c (select_class_proc): Skip abstract base types. gcc/testsuite/ 2009-12-17 Janus Weil PR fortran/42144 * gfortran.dg/dynamic_dispatch_6.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155305 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index acca306a2ff..b0c19c9627c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1556,6 +1556,10 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, if (elist->derived == NULL) goto free_elist; + /* Skip abstract base types. */ + if (elist->derived->attr.abstract) + goto free_elist; + /* Run through the chain picking up all the cases that call the same procedure. */ tmp_elist = elist; -- cgit v1.2.1 From 531692793cdfeb07aeac29c3daf772a401bc01d9 Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 4 Jan 2010 07:30:49 +0000 Subject: 2009-01-04 Tobias Burnus PR fortran/41872 * trans-expr.c (gfc_conv_procedure_call): Add indirect ref for functions returning allocatable scalars. * trans-stmt.c (gfc_trans_allocate): Emmit error when reallocating an allocatable scalar. * trans.c (gfc_allocate_with_status): Fix pseudocode syntax in comment. * trans-decl.c (gfc_trans_deferred_vars): Nullify local allocatable scalars. (gfc_generate_function_code): Nullify result variable for allocatable scalars. PR fortran/40849 * module.c (gfc_use_module): Fix warning string to allow for translation. PR fortran/42517 * invoke.texi (-fcheck=recursion): Mention that the checking is also disabled for -frecursive. * trans-decl.c (gfc_generate_function_code): Disable -fcheck=recursion when -frecursive is used. * intrinsic.texi (iso_c_binding): Improve wording. 2009-01-04 Tobias Burnus PR fortran/41872 * gfortran.dg/allocatable_scalar_5.f90: New test. * gfortran.dg/allocatable_scalar_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155606 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b0c19c9627c..84eb585f558 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3413,7 +3413,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, something like x = f() where f is pointer valued, we have to dereference the result. */ - if (!se->want_pointer && !byref && sym->attr.pointer + if (!se->want_pointer && !byref + && (sym->attr.pointer || sym->attr.allocatable) && !gfc_is_proc_ptr_comp (expr, NULL)) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); -- cgit v1.2.1 From c1de3106b314776897013d2d4fb8f9443b204d93 Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 5 Jan 2010 07:19:30 +0000 Subject: 2010-01-05 Tobias Burnus PR fortran/41872 * trans-expr.c (gfc_conv_procedure_call): Nullify return value for allocatable-scalar character functions. 2010-01-05 Tobias Burnus PR fortran/41872 * gfortran.dg/allocatable_scalar_8.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155639 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 84eb585f558..e5fce02c6c7 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3351,6 +3351,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { var = gfc_create_var (type, "pstr"); + if ((!comp && sym->attr.allocatable) + || (comp && comp->attr.allocatable)) + gfc_add_modify (&se->pre, var, + fold_convert (TREE_TYPE (var), + null_pointer_node)); + /* Provide an address expression for the function arguments. */ var = gfc_build_addr_expr (NULL_TREE, var); } -- cgit v1.2.1 From 650ee6fba83f72c04ec73f880703190eea76136c Mon Sep 17 00:00:00 2001 From: burnus Date: Sat, 9 Jan 2010 09:11:53 +0000 Subject: 2010-01-09 Tobias Burnus PR fortran/41298 * trans-expr.c (gfc_trans_structure_assign): Handle c_null_(fun)ptr. * symbol.c (gen_special_c_interop_ptr): Add NULL_EXPR to the constructor for c_null_(fun)ptr. * resolve.c (resolve_structure_cons): Add special case for c_null_(fun)ptr. 2010-01-09 Tobias Burnus PR fortran/41298 * gfortran.dg/c_ptr_tests_14.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155755 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e5fce02c6c7..5ce5dcec4c5 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1,5 +1,5 @@ /* Expression translation - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -4214,6 +4214,19 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) if (!c->expr) continue; + /* Handle c_null_(fun)ptr. */ + if (c && c->expr && c->expr->ts.is_iso_c) + { + field = cm->backend_decl; + tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), + dest, field, NULL_TREE); + tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp, + fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + gfc_add_expr_to_block (&block, tmp); + continue; + } + field = cm->backend_decl; tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE); -- cgit v1.2.1 From 64a8f98f2b7d200f6b8ddb5970d6f72a45fd4bab Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 14 Jan 2010 06:17:38 +0000 Subject: 2010-01-14 Paul Thomas PR fortran/41478 * trans-array.c (duplicate_allocatable): Static version of gfc_duplicate_allocatable with provision to handle scalar components. New boolean argument to switch off call to malloc if true. (gfc_duplicate_allocatable): New function to call above with new argument false. (gfc_copy_allocatable_data): New function to call above with new argument true. (structure_alloc_comps): Do not apply indirect reference to scalar pointers. Add new section to copy allocatable components of arrays. Extend copying of allocatable components to include scalars. (gfc_copy_only_alloc_comp): New function to copy allocatable component derived types, without allocating the base structure. * trans-array.h : Add primitive for gfc_copy_allocatable_data. Add primitive for gfc_copy_only_alloc_comp. * trans-expr.c (gfc_conv_procedure_call): After calls to transformational functions with results that are derived types with allocatable components, copy the components in the result. (gfc_trans_arrayfunc_assign): Deallocate allocatable components of lhs derived types before allocation. 2010-01-14 Paul Thomas PR fortran/41478 * gfortran.dg/alloc_comp_scalar_1.f90: New test. * gfortran.dg/alloc_comp_transformational_1.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155877 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 51 +++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 46 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 5ce5dcec4c5..bb69d454e92 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2757,6 +2757,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree var; tree len; tree stringargs; + tree result = NULL; gfc_formal_arglist *formal; int has_alternate_specifier = 0; bool need_interface_mapping; @@ -3288,6 +3289,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + result = build_fold_indirect_ref_loc (input_location, + se->expr); retargs = gfc_chainon_list (retargs, se->expr); } else if (comp && comp->attr.dimension) @@ -3310,8 +3313,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, callee_alloc, &se->ss->expr->where); /* Pass the temporary as the first argument. */ - tmp = info->descriptor; - tmp = gfc_build_addr_expr (NULL_TREE, tmp); + result = info->descriptor; + tmp = gfc_build_addr_expr (NULL_TREE, result); retargs = gfc_chainon_list (retargs, tmp); } else if (!comp && sym->result->attr.dimension) @@ -3334,8 +3337,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, callee_alloc, &se->ss->expr->where); /* Pass the temporary as the first argument. */ - tmp = info->descriptor; - tmp = gfc_build_addr_expr (NULL_TREE, tmp); + result = info->descriptor; + tmp = gfc_build_addr_expr (NULL_TREE, result); retargs = gfc_chainon_list (retargs, tmp); } else if (ts.type == BT_CHARACTER) @@ -3487,7 +3490,36 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Follow the function call with the argument post block. */ if (byref) - gfc_add_block_to_block (&se->pre, &post); + { + gfc_add_block_to_block (&se->pre, &post); + + /* Transformational functions of derived types with allocatable + components must have the result allocatable components copied. */ + arg = expr->value.function.actual; + if (result && arg && expr->rank + && expr->value.function.isym + && expr->value.function.isym->transformational + && arg->expr->ts.type == BT_DERIVED + && arg->expr->ts.u.derived->attr.alloc_comp) + { + tree tmp2; + /* Copy the allocatable components. We have to use a + temporary here to prevent source allocatable components + from being corrupted. */ + tmp2 = gfc_evaluate_now (result, &se->pre); + tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived, + result, tmp2, expr->rank); + gfc_add_expr_to_block (&se->pre, tmp); + tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2), + expr->rank); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Finally free the temporary's data field. */ + tmp = gfc_conv_descriptor_data_get (tmp2); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL); + gfc_add_expr_to_block (&se->pre, tmp); + } + } else gfc_add_block_to_block (&se->post, &post); @@ -4906,6 +4938,15 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL); + if (expr1->ts.type == BT_DERIVED + && expr1->ts.u.derived->attr.alloc_comp) + { + tree tmp; + tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr, + expr1->rank); + gfc_add_expr_to_block (&se.pre, tmp); + } + se.direct_byref = 1; se.ss = gfc_walk_expr (expr2); gcc_assert (se.ss != gfc_ss_terminator); -- cgit v1.2.1 From ffc91ac17fb327ea6eb30c38ebc8bb7add445af1 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 31 Jan 2010 12:05:22 +0000 Subject: 2010-01-31 Paul Thomas PR fortran/38324 * expr.c (gfc_get_full_arrayspec_from_expr): New function. * gfortran.h : Add prototype for above. * trans-expr.c (gfc_trans_alloc_subarray_assign): New function. (gfc_trans_subcomponent_assign): Call new function to replace the code to deal with allocatable components. * trans-intrinsic.c (gfc_conv_intrinsic_bound): Call gfc_get_full_arrayspec_from_expr to replace existing code. 2010-01-31 Paul Thomas PR fortran/38324 * gfortran.dg/alloc_comp_basics_1.f90: Remove option -O2. * gfortran.dg/alloc_comp_bounds_1.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156399 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 228 ++++++++++++++++++++++++++++++----------------- 1 file changed, 144 insertions(+), 84 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index bb69d454e92..95ae8138867 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4045,6 +4045,149 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) } +static tree +gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, + gfc_expr * expr) +{ + gfc_se se; + gfc_ss *rss; + stmtblock_t block; + tree offset; + int n; + tree tmp; + tree tmp2; + gfc_array_spec *as; + gfc_expr *arg = NULL; + + gfc_start_block (&block); + gfc_init_se (&se, NULL); + + /* Get the descriptor for the expressions. */ + rss = gfc_walk_expr (expr); + se.want_pointer = 0; + gfc_conv_expr_descriptor (&se, expr, rss); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_modify (&block, dest, se.expr); + + /* Deal with arrays of derived types with allocatable components. */ + if (cm->ts.type == BT_DERIVED + && cm->ts.u.derived->attr.alloc_comp) + tmp = gfc_copy_alloc_comp (cm->ts.u.derived, + se.expr, dest, + cm->as->rank); + else + tmp = gfc_duplicate_allocatable (dest, se.expr, + TREE_TYPE(cm->backend_decl), + cm->as->rank); + + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se.post); + + if (expr->expr_type != EXPR_VARIABLE) + gfc_conv_descriptor_data_set (&block, se.expr, + null_pointer_node); + + /* We need to know if the argument of a conversion function is a + variable, so that the correct lower bound can be used. */ + if (expr->expr_type == EXPR_FUNCTION + && expr->value.function.isym + && expr->value.function.isym->conversion + && expr->value.function.actual->expr + && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE) + arg = expr->value.function.actual->expr; + + /* Obtain the array spec of full array references. */ + if (arg) + as = gfc_get_full_arrayspec_from_expr (arg); + else + as = gfc_get_full_arrayspec_from_expr (expr); + + /* Shift the lbound and ubound of temporaries to being unity, + rather than zero, based. Always calculate the offset. */ + offset = gfc_conv_descriptor_offset_get (dest); + gfc_add_modify (&block, offset, gfc_index_zero_node); + tmp2 =gfc_create_var (gfc_array_index_type, NULL); + + for (n = 0; n < expr->rank; n++) + { + tree span; + tree lbound; + + /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9. + TODO It looks as if gfc_conv_expr_descriptor should return + the correct bounds and that the following should not be + necessary. This would simplify gfc_conv_intrinsic_bound + as well. */ + if (as && as->lower[n]) + { + gfc_se lbse; + gfc_init_se (&lbse, NULL); + gfc_conv_expr (&lbse, as->lower[n]); + gfc_add_block_to_block (&block, &lbse.pre); + lbound = gfc_evaluate_now (lbse.expr, &block); + } + else if (as && arg) + { + tmp = gfc_get_symbol_decl (arg->symtree->n.sym); + lbound = gfc_conv_descriptor_lbound_get (tmp, + gfc_rank_cst[n]); + } + else if (as) + lbound = gfc_conv_descriptor_lbound_get (dest, + gfc_rank_cst[n]); + else + lbound = gfc_index_one_node; + + lbound = fold_convert (gfc_array_index_type, lbound); + + /* Shift the bounds and set the offset accordingly. */ + tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]); + span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp, + gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n])); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound); + gfc_conv_descriptor_ubound_set (&block, dest, + gfc_rank_cst[n], tmp); + gfc_conv_descriptor_lbound_set (&block, dest, + gfc_rank_cst[n], lbound); + + tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, + gfc_conv_descriptor_lbound_get (dest, + gfc_rank_cst[n]), + gfc_conv_descriptor_stride_get (dest, + gfc_rank_cst[n])); + gfc_add_modify (&block, tmp2, tmp); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); + gfc_conv_descriptor_offset_set (&block, dest, tmp); + } + + if (arg) + { + /* If a conversion expression has a null data pointer + argument, nullify the allocatable component. */ + tree non_null_expr; + tree null_expr; + + if (arg->symtree->n.sym->attr.allocatable + || arg->symtree->n.sym->attr.pointer) + { + non_null_expr = gfc_finish_block (&block); + gfc_start_block (&block); + gfc_conv_descriptor_data_set (&block, dest, + null_pointer_node); + null_expr = gfc_finish_block (&block); + tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl); + tmp = build2 (EQ_EXPR, boolean_type_node, tmp, + fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + return build3_v (COND_EXPR, tmp, + null_expr, non_null_expr); + } + } + + return gfc_finish_block (&block); +} + + /* Assign a single component of a derived type constructor. */ static tree @@ -4055,8 +4198,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_ss *rss; stmtblock_t block; tree tmp; - tree offset; - int n; gfc_start_block (&block); @@ -4103,89 +4244,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); else if (cm->attr.allocatable) { - tree tmp2; - - gfc_init_se (&se, NULL); - - rss = gfc_walk_expr (expr); - se.want_pointer = 0; - gfc_conv_expr_descriptor (&se, expr, rss); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_modify (&block, dest, se.expr); - - if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp) - tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest, - cm->as->rank); - else - tmp = gfc_duplicate_allocatable (dest, se.expr, - TREE_TYPE(cm->backend_decl), - cm->as->rank); - + tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr); gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&block, &se.post); - - if (expr->expr_type != EXPR_VARIABLE) - gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node); - - /* Shift the lbound and ubound of temporaries to being unity, rather - than zero, based. Calculate the offset for all cases. */ - offset = gfc_conv_descriptor_offset_get (dest); - gfc_add_modify (&block, offset, gfc_index_zero_node); - tmp2 =gfc_create_var (gfc_array_index_type, NULL); - for (n = 0; n < expr->rank; n++) - { - if (expr->expr_type != EXPR_VARIABLE - && expr->expr_type != EXPR_CONSTANT) - { - tree span; - tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]); - span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp, - gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n])); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - span, gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n], - tmp); - gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n], - gfc_index_one_node); - } - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - gfc_conv_descriptor_lbound_get (dest, - gfc_rank_cst[n]), - gfc_conv_descriptor_stride_get (dest, - gfc_rank_cst[n])); - gfc_add_modify (&block, tmp2, tmp); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); - gfc_conv_descriptor_offset_set (&block, dest, tmp); - } - - if (expr->expr_type == EXPR_FUNCTION - && expr->value.function.isym - && expr->value.function.isym->conversion - && expr->value.function.actual->expr - && expr->value.function.actual->expr->expr_type - == EXPR_VARIABLE) - { - /* If a conversion expression has a null data pointer - argument, nullify the allocatable component. */ - gfc_symbol *s; - tree non_null_expr; - tree null_expr; - s = expr->value.function.actual->expr->symtree->n.sym; - if (s->attr.allocatable || s->attr.pointer) - { - non_null_expr = gfc_finish_block (&block); - gfc_start_block (&block); - gfc_conv_descriptor_data_set (&block, dest, - null_pointer_node); - null_expr = gfc_finish_block (&block); - tmp = gfc_conv_descriptor_data_get (s->backend_decl); - tmp = build2 (EQ_EXPR, boolean_type_node, tmp, - fold_convert (TREE_TYPE (tmp), - null_pointer_node)); - return build3_v (COND_EXPR, tmp, null_expr, - non_null_expr); - } - } } else { -- cgit v1.2.1 From dba1636be4ca99a50e003734eb53decca6a57b4d Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 31 Jan 2010 21:56:02 +0000 Subject: gcc/fortran/ 2010-01-31 Janus Weil PR fortran/42888 * resolve.c (resolve_allocate_expr): Move default initialization code here from gfc_trans_allocate. * trans.c (gfc_trans_code): Call gfc_trans_class_assign also for EXEC_INIT_ASSIGN. * trans-expr.c (gfc_trans_class_assign): Handle default initialization of CLASS variables via memcpy. * trans-stmt.c (gfc_trans_allocate): Move default initialization code to resolve_allocate_expr. gcc/testsuite/ 2010-01-31 Janus Weil PR fortran/42888 * gfortran.dg/allocate_derived_2.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156418 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 95ae8138867..b5091a9e4d5 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5519,6 +5519,25 @@ gfc_trans_class_assign (gfc_code *code) gfc_expr *rhs; gfc_start_block (&block); + + if (code->op == EXEC_INIT_ASSIGN) + { + /* Special case for initializing a CLASS variable on allocation. + A MEMCPY is needed to copy the full data of the dynamic type, + which may be different from the declared type. */ + gfc_se dst,src; + tree memsz; + gfc_init_se (&dst, NULL); + gfc_init_se (&src, NULL); + gfc_add_component_ref (code->expr1, "$data"); + gfc_conv_expr (&dst, code->expr1); + gfc_conv_expr (&src, code->expr2); + gfc_add_block_to_block (&block, &src.pre); + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts)); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); + gfc_add_expr_to_block (&block, tmp); + return gfc_finish_block (&block); + } if (code->expr2->ts.type != BT_CLASS) { -- cgit v1.2.1 From 3446c28b852b05b356bb0ef7bd323f5d5a82e805 Mon Sep 17 00:00:00 2001 From: pault Date: Fri, 5 Feb 2010 05:28:37 +0000 Subject: 2010-02-05 Paul Thomas PR fortran/42309 * trans-expr.c (gfc_conv_subref_array_arg): Add new argument 'formal_ptr'. If this is true, give returned descriptor unity lbounds, in all dimensions, and the appropriate offset. (gfc_conv_procedure_call); If formal is a pointer, set the last argument of gfc_conv_subref_array_arg to true. * trans.h : Add last argument for gfc_conv_subref_array_arg. * trans-io.c (set_internal_unit, gfc_trans_transfer): Set the new arg of gfc_conv_subref_array_arg to false. * trans-stmt.c (forall_make_variable_temp): The same. 2010-02-05 Paul Thomas PR fortran/42309 * gfortran.dg/subref_array_pointer_4.f90 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156512 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 44 +++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 41 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b5091a9e4d5..4a70e739e4a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2294,8 +2294,8 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping, an actual argument derived type array is copied and then returned after the function call. */ void -gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, - int g77, sym_intent intent) +gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, + sym_intent intent, bool formal_ptr) { gfc_se lse; gfc_se rse; @@ -2308,6 +2308,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, tree tmp_index; tree tmp; tree base_type; + tree size; stmtblock_t body; int n; @@ -2501,6 +2502,42 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, if (expr->ts.type == BT_CHARACTER) parmse->string_length = expr->ts.u.cl->backend_decl; + /* Determine the offset for pointer formal arguments and set the + lbounds to one. */ + if (formal_ptr) + { + size = gfc_index_one_node; + offset = gfc_index_zero_node; + for (n = 0; n < info->dimen; n++) + { + tmp = gfc_conv_descriptor_ubound_get (parmse->expr, + gfc_rank_cst[n]); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + gfc_conv_descriptor_ubound_set (&parmse->pre, + parmse->expr, + gfc_rank_cst[n], + tmp); + gfc_conv_descriptor_lbound_set (&parmse->pre, + parmse->expr, + gfc_rank_cst[n], + gfc_index_one_node); + size = gfc_evaluate_now (size, &parmse->pre); + offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, + offset, size); + offset = gfc_evaluate_now (offset, &parmse->pre); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + rse.loop->to[n], rse.loop->from[n]); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + size = fold_build2 (MULT_EXPR, gfc_array_index_type, + size, tmp); + } + + gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr, + offset); + } + /* We want either the address for the data or the address of the descriptor, depending on the mode of passing array arguments. */ if (g77) @@ -3005,7 +3042,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, is converted to a temporary, which is passed and then written back after the procedure call. */ gfc_conv_subref_array_arg (&parmse, e, f, - fsym ? fsym->attr.intent : INTENT_INOUT); + fsym ? fsym->attr.intent : INTENT_INOUT, + fsym && fsym->attr.pointer); else gfc_conv_array_parameter (&parmse, e, argss, f, fsym, sym->name, NULL); -- cgit v1.2.1 From 5b0b615625dfd3508b2e891413adf3a2c8dd270c Mon Sep 17 00:00:00 2001 From: jakub Date: Wed, 10 Feb 2010 15:10:53 +0000 Subject: PR fortran/42309 * trans-expr.c (gfc_conv_subref_array_arg): Avoid accessing info->dimen after info has been freed. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156659 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 4a70e739e4a..5c3aa850d3d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2311,6 +2311,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, tree size; stmtblock_t body; int n; + int dimen; gcc_assert (expr->expr_type == EXPR_VARIABLE); @@ -2439,9 +2440,10 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, outside the innermost loop, so the overall transfer could be optimized further. */ info = &rse.ss->data.info; + dimen = info->dimen; tmp_index = gfc_index_zero_node; - for (n = info->dimen - 1; n > 0; n--) + for (n = dimen - 1; n > 0; n--) { tree tmp_str; tmp = rse.loop->loopvar[n]; @@ -2508,7 +2510,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, { size = gfc_index_one_node; offset = gfc_index_zero_node; - for (n = 0; n < info->dimen; n++) + for (n = 0; n < dimen; n++) { tmp = gfc_conv_descriptor_ubound_get (parmse->expr, gfc_rank_cst[n]); -- cgit v1.2.1 From 08803898f86ac4e22632737f1bd52668dbb4e663 Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 20 Feb 2010 12:46:43 +0000 Subject: 2010-02-20 Paul Thomas PR fortran/36932 PR fortran/36933 PR fortran/43072 PR fortran/43111 * dependency.c (gfc_check_argument_var_dependency): Use enum value instead of arithmetic vaue for 'elemental'. (check_data_pointer_types): New function. (gfc_check_dependency): Call check_data_pointer_types. * trans-array.h : Change fourth argument of gfc_conv_array_parameter to boolean. * trans-array.c (gfc_conv_array_parameter): A contiguous array can be a dummy but it must not be assumed shape or deferred. Change fourth argument to boolean. Array constructor exprs will always be contiguous and do not need packing and unpacking. * trans-expr.c (gfc_conv_procedure_call): Clean up some white space and change fourth argument of gfc_conv_array_parameter to boolean. (gfc_trans_arrayfunc_assign): Change fourth argument of gfc_conv_array_parameter to boolean. * trans-io.c (gfc_convert_array_to_string): The same. * trans-intrinsic.c (gfc_conv_intrinsic_loc): The same. 2010-02-20 Paul Thomas PR fortran/36932 PR fortran/36933 * gfortran.dg/dependency_26.f90: New test. PR fortran/43072 * gfortran.dg/internal_pack_7.f90: New test. PR fortran/43111 * gfortran.dg/internal_pack_8.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156926 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 5c3aa850d3d..276e6456c2b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2827,18 +2827,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (!sym->attr.elemental) { gcc_assert (se->ss->type == GFC_SS_FUNCTION); - if (se->ss->useflags) - { + if (se->ss->useflags) + { gcc_assert ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) || (comp && comp->attr.dimension)); - gcc_assert (se->loop != NULL); + gcc_assert (se->loop != NULL); - /* Access the previously obtained result. */ - gfc_conv_tmp_array_ref (se); - gfc_advance_se_ss_chain (se); - return 0; - } + /* Access the previously obtained result. */ + gfc_conv_tmp_array_ref (se); + gfc_advance_se_ss_chain (se); + return 0; + } } info = &se->ss->data.info; } @@ -2872,9 +2872,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, e = arg->expr; fsym = formal ? formal->sym : NULL; parm_kind = MISSING; + if (e == NULL) { - if (se->ignore_optional) { /* Some intrinsics have already been resolved to the correct @@ -2883,15 +2883,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else if (arg->label) { - has_alternate_specifier = 1; - continue; + has_alternate_specifier = 1; + continue; } else { /* Pass a NULL pointer for an absent arg. */ gfc_init_se (&parmse, NULL); parmse.expr = null_pointer_node; - if (arg->missing_arg_type == BT_CHARACTER) + if (arg->missing_arg_type == BT_CHARACTER) parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); } } @@ -2906,8 +2906,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else if (se->ss && se->ss->useflags) { /* An elemental function inside a scalarized loop. */ - gfc_init_se (&parmse, se); - gfc_conv_expr_reference (&parmse, e); + gfc_init_se (&parmse, se); + gfc_conv_expr_reference (&parmse, e); parm_kind = ELEMENTAL; } else @@ -2917,7 +2917,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, argss = gfc_walk_expr (e); if (argss == gfc_ss_terminator) - { + { if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.cray_pointee && fsym && fsym->attr.flavor == FL_PROCEDURE) @@ -3028,7 +3028,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ALLOCATABLE or assumed shape, we do not use g77's calling convention, and pass the address of the array descriptor instead. Otherwise we use g77's calling convention. */ - int f; + bool f; f = (fsym != NULL) && !(fsym->attr.pointer || fsym->attr.allocatable) && fsym->as->type != AS_ASSUMED_SHAPE; @@ -5036,7 +5036,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_start_block (&se.pre); se.want_pointer = 1; - gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL); + gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL); if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp) -- cgit v1.2.1 From 54564d01b93944df0c0b34daf82e41280e8e3435 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 21 Feb 2010 13:06:07 +0000 Subject: 2010-02-21 Tobias Burnus PR fortran/35259 * doc/invoke.texi (-fassociative-math): Document that this option is automatically enabled for Fortran. 2010-02-21 Tobias Burnus PR fortran/35259 * gfortran.h (gfc_option_t): New flag -fprotect-parens. * lang.opt: Ditto. * option.c (gfc_init_options,gfc_handle_option): Ditto. * trans-expr.c (gfc_conv_expr_op): Use the flag. * invoke.texi: Document new -fno-protect-parens flag. 2010-02-21 Tobias Burnus PR fortran/35259 * gfortran.dg/reassoc_5.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156937 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 276e6456c2b..d71214884e2 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1222,8 +1222,9 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) switch (expr->value.op.op) { case INTRINSIC_PARENTHESES: - if (expr->ts.type == BT_REAL - || expr->ts.type == BT_COMPLEX) + if ((expr->ts.type == BT_REAL + || expr->ts.type == BT_COMPLEX) + && gfc_option.flag_protect_parens) { gfc_conv_unary_op (PAREN_EXPR, se, expr); gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr))); -- cgit v1.2.1 From 70a03b178e411bf31f7ff3d27cf955f26821d09b Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 24 Feb 2010 07:00:35 +0000 Subject: 2010-02-24 Tobias Burnus PR fortran/43042 * trans-expr.c (gfc_conv_initializer): Call directly gfc_conv_constant for C_NULL_(FUN)PTR. 2010-02-24 Tobias Burnus PR fortran/43042 * gfortran.dg/c_ptr_tests_15.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157029 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d71214884e2..ecb577a2e44 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3949,6 +3949,10 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, its kind. */ expr->ts.f90_type = derived->ts.f90_type; expr->ts.kind = derived->ts.kind; + + gfc_init_se (&se, NULL); + gfc_conv_constant (&se, expr); + return se.expr; } if (array) -- cgit v1.2.1 From cf5f0e1cfe810c6f8c3addd2591af144f1367718 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 28 Feb 2010 16:16:22 +0000 Subject: 2010-02-28 Tobias Burnus PR fortran/43205 * trans-expr.c (is_zero_initializer_p): Move up in the file. (gfc_conv_initializer): Handle zero initializer as special case. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157123 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 75 ++++++++++++++++++++++++++---------------------- 1 file changed, 40 insertions(+), 35 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index ecb577a2e44..abc2a24318a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3910,6 +3910,43 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr) } +/* Determine whether the given EXPR_CONSTANT is a zero initializer. */ + +static bool +is_zero_initializer_p (gfc_expr * expr) +{ + if (expr->expr_type != EXPR_CONSTANT) + return false; + + /* We ignore constants with prescribed memory representations for now. */ + if (expr->representation.string) + return false; + + switch (expr->ts.type) + { + case BT_INTEGER: + return mpz_cmp_si (expr->value.integer, 0) == 0; + + case BT_REAL: + return mpfr_zero_p (expr->value.real) + && MPFR_SIGN (expr->value.real) >= 0; + + case BT_LOGICAL: + return expr->value.logical == 0; + + case BT_COMPLEX: + return mpfr_zero_p (mpc_realref (expr->value.complex)) + && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0 + && mpfr_zero_p (mpc_imagref (expr->value.complex)) + && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0; + + default: + break; + } + return false; +} + + static void gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) { @@ -3960,6 +3997,9 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, /* Arrays need special handling. */ if (pointer) return gfc_build_null_descriptor (type); + /* Special case assigning an array to zero. */ + else if (is_zero_initializer_p (expr)) + return build_constructor (type, NULL); else return gfc_conv_array_initializer (type, expr); } @@ -5061,41 +5101,6 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) return gfc_finish_block (&se.pre); } -/* Determine whether the given EXPR_CONSTANT is a zero initializer. */ - -static bool -is_zero_initializer_p (gfc_expr * expr) -{ - if (expr->expr_type != EXPR_CONSTANT) - return false; - - /* We ignore constants with prescribed memory representations for now. */ - if (expr->representation.string) - return false; - - switch (expr->ts.type) - { - case BT_INTEGER: - return mpz_cmp_si (expr->value.integer, 0) == 0; - - case BT_REAL: - return mpfr_zero_p (expr->value.real) - && MPFR_SIGN (expr->value.real) >= 0; - - case BT_LOGICAL: - return expr->value.logical == 0; - - case BT_COMPLEX: - return mpfr_zero_p (mpc_realref (expr->value.complex)) - && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0 - && mpfr_zero_p (mpc_imagref (expr->value.complex)) - && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0; - - default: - break; - } - return false; -} /* Try to efficiently translate array(:) = 0. Return NULL if this can't be done. */ -- cgit v1.2.1 From 8fcd6158bb904c5f6b404d1297aeb85275a6b9ae Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 18 Mar 2010 21:23:35 +0000 Subject: 2010-03-18 Paul Thomas PR fortran/43039 * trans-expr.c (conv_parent_component_references): Ensure that 'dt' has a backend_decl. PR fortran/43043 * trans-expr.c (gfc_conv_structure): Ensure that the derived type has a backend_decl. PR fortran/43044 * resolve.c (resolve_global_procedure): Check that the 'cl' structure is not NULL. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157552 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index abc2a24318a..b9ea5579ac8 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -507,6 +507,9 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref) parent.u.c.sym = dt; parent.u.c.component = dt->components; + if (dt->backend_decl == NULL) + gfc_get_derived_type (dt); + if (dt->attr.extension && dt->components) { if (dt->attr.is_class) @@ -4454,6 +4457,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) { gfc_component *data; data = gfc_find_component (cm->ts.u.derived, "$data", true, true); + if (!data->backend_decl) + gfc_get_derived_type (cm->ts.u.derived); val = gfc_conv_initializer (c->expr, &cm->ts, TREE_TYPE (data->backend_decl), data->attr.dimension, -- cgit v1.2.1 From a545a8f8abd6e1cd14a105138a3f34b986cab285 Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Apr 2010 12:46:19 +0000 Subject: 2010-04-06 Tobias Burnus PR fortran/43178 * trans-array.c (gfc_conv_expr_descriptor): Update gfc_trans_scalar_assign call. (has_default_initializer): New function. (gfc_trans_deferred_array): Nullify less often. * trans-expr.c (gfc_conv_subref_array_arg, gfc_trans_subcomponent_assign): Update call to gfc_trans_scalar_assign. (gfc_trans_scalar_assign): Add parameter and pass it on. (gfc_trans_assignment_1): Optionally, do not dealloc before assignment. * trans-openmp.c (gfc_trans_omp_array_reduction): Update call to gfc_trans_scalar_assign. * trans-decl.c (gfc_get_symbol_decl): Do not always apply initializer to static variables. (gfc_init_default_dt): Add dealloc parameter and pass it on. * trans-stmt.c (forall_make_variable_temp, generate_loop_for_temp_to_lhs, generate_loop_for_rhs_to_temp, gfc_trans_forall_1, gfc_trans_where_assign, gfc_trans_where_3 gfc_trans_allocate): Update gfc_trans_assignment call. * trans.h (gfc_trans_scalar_assign, gfc_init_default_dt, gfc_init_default_dt, gfc_trans_assignment): Add bool dealloc parameter to prototype. 2010-04-06 Tobias Burnus PR fortran/43178 * gfortran.dg/alloc_comp_basics_1.f90: Update * scan-tree-dump-times. * gfortran.dg/alloc_comp_constructor_1.f90: Ditto. * gfortran.dg/auto_dealloc_1.f90: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157993 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 37 +++++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 16 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b9ea5579ac8..7e95ce11390 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2386,7 +2386,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, if (intent != INTENT_OUT) { - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); gfc_trans_scalarizing_loops (&loop, &body); @@ -2484,7 +2484,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, gcc_assert (lse.ss == gfc_ss_terminator); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true); gfc_add_expr_to_block (&body, tmp); /* Generate the copying loops. */ @@ -4111,7 +4111,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_expr (&rse, expr); - tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false); + tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); @@ -4369,7 +4369,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) if (cm->ts.type == BT_CHARACTER) lse.string_length = cm->ts.u.cl->backend_decl; lse.expr = dest; - tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false); + tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); @@ -4897,11 +4897,12 @@ gfc_conv_string_parameter (gfc_se * se) /* Generate code for assignment of scalar variables. Includes character - strings and derived types with allocatable components. */ + strings and derived types with allocatable components. + If you know that the LHS has no allocations, set dealloc to false. */ tree gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, - bool l_is_temp, bool r_is_var) + bool l_is_temp, bool r_is_var, bool dealloc) { stmtblock_t block; tree tmp; @@ -4949,7 +4950,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, the same as the rhs. This must be done following the assignment to prevent deallocating data that could be used in the rhs expression. */ - if (!l_is_temp) + if (!l_is_temp && dealloc) { tmp = gfc_evaluate_now (lse->expr, &lse->pre); tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); @@ -5279,10 +5280,13 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) /* Subroutine of gfc_trans_assignment that actually scalarizes the - assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */ + assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. + init_flag indicates initialization expressions and dealloc that no + deallocate prior assignment is needed (if in doubt, set true). */ static tree -gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) +gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, + bool dealloc) { gfc_se lse; gfc_se rse; @@ -5399,7 +5403,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) && expr2->expr_type != EXPR_VARIABLE && !gfc_is_constant_expr (expr2) && expr1->rank && !expr2->rank); - if (scalar_to_array) + if (scalar_to_array && dealloc) { tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0); gfc_add_expr_to_block (&loop.post, tmp); @@ -5408,7 +5412,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp || init_flag, (expr2->expr_type == EXPR_VARIABLE) - || scalar_to_array); + || scalar_to_array, dealloc); gfc_add_expr_to_block (&body, tmp); if (lss == gfc_ss_terminator) @@ -5445,7 +5449,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) rse.string_length = string_length; tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - false, false); + false, false, dealloc); gfc_add_expr_to_block (&body, tmp); } @@ -5503,7 +5507,8 @@ copyable_array_p (gfc_expr * expr) /* Translate an assignment. */ tree -gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) +gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, + bool dealloc) { tree tmp; @@ -5546,19 +5551,19 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) } /* Fallback to the scalarizer to generate explicit loops. */ - return gfc_trans_assignment_1 (expr1, expr2, init_flag); + return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc); } tree gfc_trans_init_assign (gfc_code * code) { - return gfc_trans_assignment (code->expr1, code->expr2, true); + return gfc_trans_assignment (code->expr1, code->expr2, true, false); } tree gfc_trans_assign (gfc_code * code) { - return gfc_trans_assignment (code->expr1, code->expr2, false); + return gfc_trans_assignment (code->expr1, code->expr2, false, true); } -- cgit v1.2.1 From e97ac7c06c53487872b7d9d11148725317ef5588 Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 9 Apr 2010 05:54:29 +0000 Subject: 2010-04-09 Tobias Burnus PR fortran/18918 * decl.c (variable_decl, match_attr_spec): Fix setting the array spec. * array.c (match_subscript,gfc_match_array_ref): Add coarray * support. * data.c (gfc_assign_data_value): Ditto. * expr.c (gfc_check_pointer_assign): Add check for coarray * constraint. (gfc_traverse_expr): Traverse also through codimension expressions. (gfc_is_coindexed, gfc_has_ultimate_allocatable, gfc_has_ultimate_pointer): New functions. * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for * coarrays. (gfc_array_ref): Add codimen. (gfc_array_ref): Add in_allocate. (gfc_is_coindexed, gfc_has_ultimate_allocatable, gfc_has_ultimate_pointer): Add prototypes. * interface.c (compare_parameter, compare_actual_formal, check_intents): Add coarray constraints. * match.c (gfc_match_iterator): Add coarray constraint. * match.h (gfc_match_array_ref): Update interface. * primary.c (gfc_match_varspec): Handle codimensions. * resolve.c (coarray_alloc, inquiry_argument): New static * variables. (check_class_members): Return gfc_try instead for error recovery. (resolve_typebound_function,resolve_typebound_subroutine, check_members): Handle return value of check_class_members. (resolve_structure_cons, resolve_actual_arglist, resolve_function, check_dimension, compare_spec_to_ref, resolve_array_ref, resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays, resolve_allocate_expr, resolve_ordinary_assign): Add coarray support. * trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr): Skip over coarray refs. (gfc_array_allocate) Add support for references containing coindexes. * trans-expr.c (gfc_add_interface_mapping): Copy coarray * attribute. (gfc_map_intrinsic_function): Ignore codimensions. 2010-04-09 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_7.f90: New test. * gfortran.dg/coarray_8.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158149 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7e95ce11390..10716b70692 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1848,6 +1848,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, new_sym->as = gfc_copy_array_spec (sym->as); new_sym->attr.referenced = 1; new_sym->attr.dimension = sym->attr.dimension; + new_sym->attr.codimension = sym->attr.codimension; new_sym->attr.pointer = sym->attr.pointer; new_sym->attr.allocatable = sym->attr.allocatable; new_sym->attr.flavor = sym->attr.flavor; @@ -2076,7 +2077,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) break; case GFC_ISYM_SIZE: - if (!sym->as) + if (!sym->as || sym->as->rank == 0) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) @@ -2114,7 +2115,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) /* TODO These implementations of lbound and ubound do not limit if the size < 0, according to F95's 13.14.53 and 13.14.113. */ - if (!sym->as) + if (!sym->as || sym->as->rank == 0) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) -- cgit v1.2.1 From 126387b5b6b5a55db23d87e27562c91cc235c906 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Tue, 13 Apr 2010 01:59:35 +0000 Subject: 2010-04-12 Jerry DeLisle * array.c (extract_element): Restore function from trunk. (gfc_get_array_element): Restore function from trunk. (gfc_expand_constructor): Restore check against flag_max_array_constructor. * constructor.c (node_copy_and_append): Delete unused. * gfortran.h: Delete comment and extra include. * constructor.h: Bump copyright and clean up TODO comments. * resolve.c: Whitespace. 2010-04-12 Daniel Franke * simplify.c (compute_dot_product): Replaced usage of ADVANCE macro with direct access access to elements. Adjusted prototype, fixed all callers. (gfc_simplify_dot_product): Removed duplicate check for zero-sized array. (gfc_simplify_matmul): Removed usage of ADVANCE macro. (gfc_simplify_spread): Removed workaround, directly insert elements at a given array position. (gfc_simplify_transpose): Likewise. (gfc_simplify_pack): Replaced usage of ADVANCE macro with corresponding function calls. (gfc_simplify_unpack): Likewise. 2010-04-12 Daniel Franke * simplify.c (only_convert_cmplx_boz): Renamed to ... (convert_boz): ... this and moved to start of file. (gfc_simplify_abs): Whitespace fix. (gfc_simplify_acos): Whitespace fix. (gfc_simplify_acosh): Whitespace fix. (gfc_simplify_aint): Whitespace fix. (gfc_simplify_dint): Whitespace fix. (gfc_simplify_anint): Whitespace fix. (gfc_simplify_and): Replaced if-gate by more common switch-over-type. (gfc_simplify_dnint): Whitespace fix. (gfc_simplify_asin): Whitespace fix. (gfc_simplify_asinh): Moved creation of result-expr out of switch. (gfc_simplify_atan): Likewise. (gfc_simplify_atanh): Whitespace fix. (gfc_simplify_atan2): Whitespace fix. (gfc_simplify_bessel_j0): Removed ATTRIBUTE_UNUSED. (gfc_simplify_bessel_j1): Likewise. (gfc_simplify_bessel_jn): Likewise. (gfc_simplify_bessel_y0): Likewise. (gfc_simplify_bessel_y1): Likewise. (gfc_simplify_bessel_yn): Likewise. (gfc_simplify_ceiling): Reorderd statements. (simplify_cmplx): Use convert_boz(), check for constant arguments. Whitespace fix. (gfc_simplify_cmplx): Use correct default kind. Removed check for constant arguments. (gfc_simplify_complex): Replaced if-gate. Removed check for constant arguments. (gfc_simplify_conjg): Whitespace fix. (gfc_simplify_cos): Whitespace fix. (gfc_simplify_cosh): Replaced if-gate by more common switch-over-type. (gfc_simplify_dcmplx): Removed check for constant arguments. (gfc_simplify_dble): Use convert_boz() and gfc_convert_constant(). (gfc_simplify_digits): Whitespace fix. (gfc_simplify_dim): Whitespace fix. (gfc_simplify_dprod): Reordered statements. (gfc_simplify_erf): Whitespace fix. (gfc_simplify_erfc): Whitespace fix. (gfc_simplify_epsilon): Whitespace fix. (gfc_simplify_exp): Whitespace fix. (gfc_simplify_exponent): Use convert_boz(). (gfc_simplify_floor): Reorderd statements. (gfc_simplify_gamma): Whitespace fix. (gfc_simplify_huge): Whitespace fix. (gfc_simplify_iand): Whitespace fix. (gfc_simplify_ieor): Whitespace fix. (simplify_intconv): Use gfc_convert_constant(). (gfc_simplify_int): Use simplify_intconv(). (gfc_simplify_int2): Reorderd statements. (gfc_simplify_idint): Reorderd statements. (gfc_simplify_ior): Whitespace fix. (gfc_simplify_ishftc): Removed duplicate type check. (gfc_simplify_len): Use range_check() instead of manual range check. (gfc_simplify_lgamma): Removed ATTRIBUTE_UNUSED. Whitespace fix. (gfc_simplify_log): Whitespace fix. (gfc_simplify_log10): Whitespace fix. (gfc_simplify_minval): Whitespace fix. (gfc_simplify_maxval): Whitespace fix. (gfc_simplify_mod): Whitespace fix. (gfc_simplify_modulo): Whitespace fix. (simplify_nint): Reorderd statements. (gfc_simplify_not): Whitespace fix. (gfc_simplify_or): Replaced if-gate by more common switch-over-type. (gfc_simplify_radix): Removed unused result-variable. Whitespace fix. (gfc_simplify_range): Removed unused result-variable. Whitespace fix. (gfc_simplify_real): Use convert_boz() and gfc_convert_constant(). (gfc_simplify_realpart): Whitespace fix. (gfc_simplify_selected_char_kind): Removed unused result-variable. (gfc_simplify_selected_int_kind): Removed unused result-variable. (gfc_simplify_selected_real_kind): Removed unused result-variable. (gfc_simplify_sign): Whitespace fix. (gfc_simplify_sin): Whitespace fix. (gfc_simplify_sinh): Replaced if-gate by more common switch-over-type. (gfc_simplify_sqrt): Avoided goto by inlining check. Whitespace fix. (gfc_simplify_tan): Replaced if-gate by more common switch-over-type. (gfc_simplify_tanh): Replaced if-gate by more common switch-over-type. (gfc_simplify_xor): Replaced if-gate by more common switch-over-type. 2010-04-12 Daniel Franke * gfortran.h (gfc_start_constructor): Removed. (gfc_get_array_element): Removed. * array.c (gfc_start_constructor): Removed, use gfc_get_array_expr instead. Fixed all callers. (extract_element): Removed. (gfc_expand_constructor): Temporarily removed check for max-array-constructor. Will be re-introduced later if still required. (gfc_get_array_element): Removed, use gfc_constructor_lookup_expr instead. Fixed all callers. * expr.c (find_array_section): Replaced manual lookup of elements by gfc_constructor_lookup. 2010-04-12 Daniel Franke * gfortran.h (gfc_get_null_expr): New prototype. (gfc_get_operator_expr): New prototype. (gfc_get_character_expr): New prototype. (gfc_get_iokind_expr): New prototype. * expr.c (gfc_get_null_expr): New. (gfc_get_character_expr): New. (gfc_get_iokind_expr): New. (gfc_get_operator_expr): Moved here from matchexp.c (build_node). * matchexp.c (build_node): Renamed and moved to expr.c (gfc_get_operator_expr). Reordered arguments to match other functions. Fixed all callers. (gfc_get_parentheses): Use specific function to build expr. * array.c (gfc_match_array_constructor): Likewise. * arith.c (eval_intrinsic): Likewise. (gfc_hollerith2int): Likewise. (gfc_hollerith2real): Likewise. (gfc_hollerith2complex): Likewise. (gfc_hollerith2logical): Likewise. * data.c (create_character_intializer): Likewise. * decl.c (gfc_match_null): Likewise. (enum_initializer): Likewise. * io.c (gfc_match_format): Likewise. (match_io): Likewise. * match.c (gfc_match_nullify): Likewise. * primary.c (match_string_constant): Likewise. (match_logical_constant): Likewise. (build_actual_constructor): Likewise. * resolve.c (build_default_init_expr): Likewise. * symbol.c (generate_isocbinding_symbol): Likewise. (gfc_build_class_symbol): Likewise. (gfc_find_derived_vtab): Likewise. * simplify.c (simplify_achar_char): Likewise. (gfc_simplify_adjustl): Likewise. (gfc_simplify_adjustr): Likewise. (gfc_simplify_and): Likewise. (gfc_simplify_bit_size): Likewise. (gfc_simplify_is_iostat_end): Likewise. (gfc_simplify_is_iostat_eor): Likewise. (gfc_simplify_isnan): Likewise. (simplify_bound): Likewise. (gfc_simplify_leadz): Likewise. (gfc_simplify_len_trim): Likewise. (gfc_simplify_logical): Likewise. (gfc_simplify_maxexponent): Likewise. (gfc_simplify_minexponent): Likewise. (gfc_simplify_new_line): Likewise. (gfc_simplify_null): Likewise. (gfc_simplify_or): Likewise. (gfc_simplify_precision): Likewise. (gfc_simplify_repeat): Likewise. (gfc_simplify_scan): Likewise. (gfc_simplify_size): Likewise. (gfc_simplify_trailz): Likewise. (gfc_simplify_trim): Likewise. (gfc_simplify_verify): Likewise. (gfc_simplify_xor): Likewise. * trans-io.c (build_dt): Likewise. (gfc_new_nml_name_expr): Removed. 2010-04-12 Daniel Franke * arith.h (gfc_constant_result): Removed prototype. * constructor.h (gfc_build_array_expr): Removed prototype. (gfc_build_structure_constructor_expr): Removed prototype. * gfortran.h (gfc_int_expr): Removed prototype. (gfc_logical_expr): Removed prototype. (gfc_get_array_expr): New prototype. (gfc_get_structure_constructor_expr): New prototype. (gfc_get_constant_expr): New prototype. (gfc_get_int_expr): New prototype. (gfc_get_logical_expr): New prototype. * arith.c (gfc_constant_result): Moved and renamed to expr.c (gfc_get_constant_expr). Fixed all callers. * constructor.c (gfc_build_array_expr): Moved and renamed to expr.c (gfc_get_array_expr). Split gfc_typespec argument to type and kind. Fixed all callers. (gfc_build_structure_constructor_expr): Moved and renamed to expr.c (gfc_get_structure_constructor_expr). Split gfc_typespec argument to type and kind. Fixed all callers. * expr.c (gfc_logical_expr): Renamed to ... (gfc_get_logical_expr): ... this. Added kind argument. Fixed all callers. (gfc_int_expr): Renamed to ... (gfc_get_int_expr): ... this. Added kind and where arguments. Fixed all callers. (gfc_get_constant_expr): New. (gfc_get_array_expr): New. (gfc_get_structure_constructor_expr): New. * simplify.c (int_expr_with_kind): Removed, callers use gfc_get_int_expr instead. 2010-04-12 Daniel Franke * constructor.h: New. * constructor.c: New. * Make-lang.in: Add new files to F95_PARSER_OBJS. * arith.c (reducy_unary): Use constructor API. (reduce_binary_ac): Likewise. (reduce_binary_ca): Likewise. (reduce_binary_aa): Likewise. * check.c (gfc_check_pack): Likewise. (gfc_check_reshape): Likewise. (gfc_check_unpack): Likewise. * decl.c (add_init_expr_to_sym): Likewise. (build_struct): Likewise. * dependency.c (gfc_check_dependency): Likewise. (contains_forall_index_p): Likewise. * dump-parse-tree.c (show_constructor): Likewise. * expr.c (free_expr0): Likewise. (gfc_copy_expr): Likewise. (gfc_is_constant_expr): Likewise. (simplify_constructor): Likewise. (find_array_element): Likewise. (find_component_ref): Likewise. (find_array_section): Likewise. (find_substring_ref): Likewise. (simplify_const_ref): Likewise. (scalarize_intrinsic_call): Likewise. (check_alloc_comp_init): Likewise. (gfc_default_initializer): Likewise. (gfc_traverse_expr): Likewise. * iresolve.c (check_charlen_present): Likewise. (gfc_resolve_reshape): Likewise. (gfc_resolve_transfer): Likewise. * module.c (mio_constructor): Likewise. * primary.c (build_actual_constructor): Likewise. (gfc_match_structure_constructor): Likewise. * resolve.c (resolve_structure_cons): Likewise. * simplify.c (is_constant_array_expr): Likewise. (init_result_expr): Likewise. (transformational_result): Likewise. (simplify_transformation_to_scalar): Likewise. (simplify_transformation_to_array): Likewise. (gfc_simplify_dot_product): Likewise. (simplify_bound): Likewise. (simplify_matmul): Likewise. (simplify_minval_maxval): Likewise. (gfc_simplify_pack): Likewise. (gfc_simplify_reshape): Likewise. (gfc_simplify_shape): Likewise. (gfc_simplify_spread): Likewise. (gfc_simplify_transpose): Likewise. (gfc_simplify_unpack): Likewise.q (gfc_convert_constant): Likewise. (gfc_convert_char_constant): Likewise. * target-memory.c (size_array): Likewise. (encode_array): Likewise. (encode_derived): Likewise. (interpret_array): Likewise. (gfc_interpret_derived): Likewise. (expr_to_char): Likewise. (gfc_merge_initializers): Likewise. * trans-array.c (gfc_get_array_constructor_size): Likewise. (gfc_trans_array_constructor_value): Likewise. (get_array_ctor_strlen): Likewise. (gfc_constant_array_constructor_p): Likewise. (gfc_build_constant_array_constructor): Likewise. (gfc_trans_array_constructor): Likewise. (gfc_conv_array_initializer): Likewise. * trans-decl.c (check_constant_initializer): Likewise. * trans-expr.c (flatten_array_ctors_without_strlen): Likewise. (gfc_apply_interface_mapping_to_cons): Likewise. (gfc_trans_structure_assign): Likewise. (gfc_conv_structure): Likewise. * array.c (check_duplicate_iterator): Likewise. (match_array_list): Likewise. (match_array_cons_element): Likewise. (gfc_match_array_constructor): Likewise. (check_constructor_type): Likewise. (check_constructor): Likewise. (expand): Likewise. (expand_constructor): Likewise. (extract_element): Likewise. (gfc_expanded_ac): Likewise. (resolve_array_list): Likewise. (gfc_resolve_character_array_constructor): Likewise. (copy_iterator): Renamed to ... (gfc_copy_iterator): ... this. (gfc_append_constructor): Removed. (gfc_insert_constructor): Removed unused function. (gfc_get_constructor): Removed. (gfc_free_constructor): Removed. (qgfc_copy_constructor): Removed. * gfortran.h (struct gfc_expr): Removed member 'con_by_offset'. Removed all references. Replaced constructor list by splay-tree. (struct gfc_constructor): Removed member 'next', moved 'offset' from the inner struct, added member 'base'. (gfc_append_constructor): Removed prototype. (gfc_insert_constructor): Removed prototype. (gfc_get_constructor): Removed prototype. (gfc_free_constructor): Removed prototype. (qgfc_copy_constructor): Removed prototype. (gfc_copy_iterator): New prototype. * trans-array.h (gfc_constant_array_constructor_p): Adjusted prototype. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158253 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 35 ++++++++++++++++++++++------------- 1 file changed, 22 insertions(+), 13 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 10716b70692..42e1d34d38c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "flags.h" #include "gfortran.h" #include "arith.h" +#include "constructor.h" #include "trans.h" #include "trans-const.h" #include "trans-types.h" @@ -278,11 +279,14 @@ flatten_array_ctors_without_strlen (gfc_expr* e) /* We've found what we're looking for. */ if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length) { + gfc_constructor *c; gfc_expr* new_expr; + gcc_assert (e->value.constructor); - new_expr = e->value.constructor->expr; - e->value.constructor->expr = NULL; + c = gfc_constructor_first (e->value.constructor); + new_expr = c->expr; + c->expr = NULL; flatten_array_ctors_without_strlen (new_expr); gfc_replace_expr (e, new_expr); @@ -291,7 +295,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e) /* Otherwise, fall through to handle constructor elements. */ case EXPR_STRUCTURE: - for (c = e->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) flatten_array_ctors_without_strlen (c->expr); break; @@ -1432,7 +1437,8 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) gfc_typespec ts; gfc_clear_ts (&ts); - *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]); + *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, + (int)(*expr)->value.character.string[0]); if ((*expr)->ts.kind != gfc_c_int_kind) { /* The expr needs to be compatible with a C int. If the @@ -1991,9 +1997,10 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping, static void gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping, - gfc_constructor * c) + gfc_constructor_base base) { - for (; c; c = c->next) + gfc_constructor *c; + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { gfc_apply_interface_mapping_to_expr (mapping, c->expr); if (c->iterator) @@ -2101,7 +2108,9 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) return false; } - tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1)); + tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), + gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1)); tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d])); if (new_expr) new_expr = gfc_multiply (new_expr, tmp); @@ -3984,12 +3993,10 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, { gfc_symbol *derived = expr->ts.u.derived; - expr = gfc_int_expr (0); - /* The derived symbol has already been converted to a (void *). Use its kind. */ + expr = gfc_get_int_expr (derived->ts.kind, NULL, 0); expr->ts.f90_type = derived->ts.f90_type; - expr->ts.kind = derived->ts.kind; gfc_init_se (&se, NULL); gfc_conv_constant (&se, expr); @@ -4389,7 +4396,8 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) gfc_start_block (&block); cm = expr->ts.u.derived->components; - for (c = expr->value.constructor; c; c = c->next, cm = cm->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c), cm = cm->next) { /* Skip absent members in default initializers. */ if (!c->expr) @@ -4445,7 +4453,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) cm = expr->ts.u.derived->components; - for (c = expr->value.constructor; c; c = c->next, cm = cm->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c), cm = cm->next) { /* Skip absent members in default initializers and allocatable components. Although the latter have a default initializer @@ -5619,7 +5628,7 @@ gfc_trans_class_assign (gfc_code *code) rhs->ts = vtab->ts; } else if (code->expr2->expr_type == EXPR_NULL) - rhs = gfc_int_expr (0); + rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); else gcc_unreachable (); -- cgit v1.2.1 From 4abd9760eb011a4591eab7af5a186b5b67db4235 Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 24 Apr 2010 09:28:32 +0000 Subject: 2010-04-24 Paul Thomas PR fortran/43841 PR fortran/43843 * trans-expr.c (gfc_conv_expr): Supply an address expression for GFC_SS_REFERENCE. (gfc_conv_expr_reference): Call gfc_conv_expr and return for GFC_SS_REFERENCE. * trans-array.c (gfc_add_loop_ss_code): Store the value rather than the address of a GFC_SS_REFERENCE. * trans.h : Change comment on GFC_SS_REFERENCE. 2010-04-24 Paul Thomas PR fortran/43841 PR fortran/43843 * gfortran.dg/elemental_scalar_args_1.f90 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158683 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 42e1d34d38c..dc138a37b96 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4541,6 +4541,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) /* Substitute a scalar expression evaluated outside the scalarization loop. */ se->expr = se->ss->data.scalar.expr; + if (se->ss->type == GFC_SS_REFERENCE) + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); se->string_length = se->ss->string_length; gfc_advance_se_ss_chain (se); return; @@ -4661,9 +4663,9 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) if (se->ss && se->ss->expr == expr && se->ss->type == GFC_SS_REFERENCE) { - se->expr = se->ss->data.scalar.expr; - se->string_length = se->ss->string_length; - gfc_advance_se_ss_chain (se); + /* Returns a reference to the scalar evaluated outside the loop + for this case. */ + gfc_conv_expr (se, expr); return; } -- cgit v1.2.1 From 09c509edcc2f6e6859f02de43ce0fe10a941a8d7 Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 29 Apr 2010 19:10:48 +0000 Subject: 2010-04-29 Janus Weil PR fortran/43896 * symbol.c (add_proc_component,copy_vtab_proc_comps): Remove initializers for PPC members of the vtabs. 2010-04-29 Janus Weil PR fortran/42274 * symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc' attribute for all PPC members of the vtypes. (copy_vtab_proc_comps): Copy the correct interface. * trans.h (gfc_trans_assign_vtab_procs): Modified prototype. * trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as a dummy argument and make sure all PPC members of the vtab are initialized correctly. (gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument in call to gfc_trans_assign_vtab_procs. * trans-stmt.c (gfc_trans_allocate): Ditto. 2010-04-29 Paul Thomas PR fortran/43326 * resolve.c (resolve_typebound_function): Renamed resolve_class_compcall.Do all the detection of class references here. (resolve_typebound_subroutine): resolve_class_typebound_call renamed. Otherwise same as resolve_typebound_function. (gfc_resolve_expr): Call resolve_typebound_function. (resolve_code): Call resolve_typebound_subroutine. 2010-04-29 Janus Weil PR fortran/43492 * resolve.c (resolve_typebound_generic_call): For CLASS methods pass back the specific symtree name, rather than the target name. 2010-04-29 Paul Thomas PR fortran/42353 * resolve.c (resolve_structure_cons): Make the initializer of the vtab component 'extends' the same type as the component. 2010-04-29 Jerry DeLisle PR fortran/42680 * interface.c (check_interface1): Pass symbol name rather than NULL to gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to trap MULL. (gfc_compare_derived_types): Revert previous change incorporated incorrectly during merge from trunk, r155778. * resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather than NULL to gfc_compare_interfaces. * symbol.c (add_generic_specifics): Likewise. 2010-02-29 Janus Weil PR fortran/42353 * interface.c (gfc_compare_derived_types): Add condition for vtype. * symbol.c (gfc_find_derived_vtab): Sey access to private. (gfc_find_derived_vtab): Likewise. * module.c (ab_attribute): Add enumerator AB_VTAB. (mio_symbol_attribute): Use new attribute, AB_VTAB. (check_for_ambiguous): Likewise. 2010-04-29 Paul Thomas Janus Weil PR fortran/41829 * trans-expr.c (select_class_proc): Remove function. (conv_function_val): Delete reference to previous. (gfc_conv_derived_to_class): Add second argument to the call to gfc_find_derived_vtab. (gfc_conv_structure): Exclude proc_pointer components when accessing $data field of class objects. (gfc_trans_assign_vtab_procs): New function. (gfc_trans_class_assign): Add second argument to the call to gfc_find_derived_vtab. * symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and implement holding off searching for the vptr derived type. (add_proc_component): New function. (add_proc_comps): New function. (add_procs_to_declared_vtab1): New function. (copy_vtab_proc_comps): New function. (add_procs_to_declared_vtab): New function. (void add_generic_specifics): New function. (add_generics_to_declared_vtab): New function. (gfc_find_derived_vtab): Add second argument to the call to gfc_find_derived_vtab. Add the calls to add_procs_to_declared_vtab and add_generics_to_declared_vtab. * decl.c (build_sym, build_struct): Use new arg in calls to gfc_build_class_symbol. * gfortran.h : Add vtype bitfield to symbol_attr. Remove the definition of struct gfc_class_esym_list. Modify prototypes of gfc_build_class_symbol and gfc_find_derived_vtab. * trans-stmt.c (gfc_trans_allocate): Add second argument to the call to gfc_find_derived_vtab. * module.c : Add the vtype attribute. * trans.h : Add prototype for gfc_trans_assign_vtab_procs. * resolve.c (resolve_typebound_generic_call): Add second arg to pass along the generic name for class methods. (resolve_typebound_call): The same. (resolve_compcall): Use the second arg to carry the generic name from the above. Remove the reference to class_esym. (check_members, check_class_members, resolve_class_esym, hash_value_expr): Remove functions. (resolve_class_compcall, resolve_class_typebound_call): Modify to use vtable rather than member by member calls. (gfc_resolve_expr): Modify second arg in call to resolve_compcall. (resolve_select_type): Add second arg in call to gfc_find_derived_vtab. (resolve_code): Add second arg in call resolve_typebound_call. (resolve_fl_derived): Exclude vtypes from check for late procedure definitions. Likewise for checking of explicit interface and checking of pass arg. * iresolve.c (gfc_resolve_extends_type_of): Add second arg in calls to gfc_find_derived_vtab. * match.c (select_type_set_tmp): Use new arg in call to gfc_build_class_symbol. * trans-decl.c (gfc_get_symbol_decl): Complete vtable if necessary. * parse.c (endType): Finish incomplete classes. 2010-04-29 Janus Weil PR fortran/42274 * gfortran.dg/class_16.f03: New test. 2010-04-29 Janus Weil PR fortran/42274 * gfortran.dg/class_15.f03: New. 2010-04-29 Paul Thomas PR fortran/43326 * gfortran.dg/dynamic_dispatch_9.f03: New test. 2010-04-29 Janus Weil PR fortran/43492 * gfortran.dg/generic_22.f03 : New test. 2010-04-29 Paul Thomas PR fortran/42353 * gfortran.dg/class_14.f03: New test. 2010-04-29 Jerry DeLisle PR fortran/42680 * gfortran.dg/interface_32.f90: New test. 2009-04-29 Paul Thomas Janus Weil PR fortran/41829 * gfortran.dg/dynamic_dispatch_5.f03 : Change to "run". * gfortran.dg/dynamic_dispatch_7.f03 : New test. * gfortran.dg/dynamic_dispatch_8.f03 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158910 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 241 +++++++++++++++++++++-------------------------- 1 file changed, 105 insertions(+), 136 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index dc138a37b96..dfd38cc7e77 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1532,141 +1532,11 @@ get_proc_ptr_comp (gfc_expr *e) } -/* Select a class typebound procedure at runtime. */ -static void -select_class_proc (gfc_se *se, gfc_class_esym_list *elist, - tree declared, gfc_expr *expr) -{ - tree end_label; - tree label; - tree tmp; - tree hash; - stmtblock_t body; - gfc_class_esym_list *next_elist, *tmp_elist; - gfc_se tmpse; - - /* Convert the hash expression. */ - gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, elist->hash_value); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - hash = gfc_evaluate_now (tmpse.expr, &se->pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - - /* Fix the function type to be that of the declared type method. */ - declared = gfc_create_var (TREE_TYPE (declared), "method"); - - end_label = gfc_build_label_decl (NULL_TREE); - - gfc_init_block (&body); - - /* Go through the list of extensions. */ - for (; elist; elist = next_elist) - { - /* This case has already been added. */ - if (elist->derived == NULL) - goto free_elist; - - /* Skip abstract base types. */ - if (elist->derived->attr.abstract) - goto free_elist; - - /* Run through the chain picking up all the cases that call the - same procedure. */ - tmp_elist = elist; - for (; elist; elist = elist->next) - { - tree cval; - - if (elist->esym != tmp_elist->esym) - continue; - - cval = build_int_cst (TREE_TYPE (hash), - elist->derived->hash_value); - /* Build a label for the hash value. */ - label = gfc_build_label_decl (NULL_TREE); - tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, - cval, NULL_TREE, label); - gfc_add_expr_to_block (&body, tmp); - - /* Null the reference the derived type so that this case is - not used again. */ - elist->derived = NULL; - } - - elist = tmp_elist; - - /* Get a pointer to the procedure, */ - tmp = gfc_get_symbol_decl (elist->esym); - if (!POINTER_TYPE_P (TREE_TYPE (tmp))) - { - gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - } - - /* Assign the pointer to the appropriate procedure. */ - gfc_add_modify (&body, declared, - fold_convert (TREE_TYPE (declared), tmp)); - - /* Break to the end of the construct. */ - tmp = build1_v (GOTO_EXPR, end_label); - gfc_add_expr_to_block (&body, tmp); - - /* Free the elists as we go; freeing them in gfc_free_expr causes - segfaults because it occurs too early and too often. */ - free_elist: - next_elist = elist->next; - if (elist->hash_value) - gfc_free_expr (elist->hash_value); - gfc_free (elist); - elist = NULL; - } - - /* Default is an error. */ - label = gfc_build_label_decl (NULL_TREE); - tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, - NULL_TREE, NULL_TREE, label); - gfc_add_expr_to_block (&body, tmp); - tmp = gfc_trans_runtime_error (true, &expr->where, - "internal error: bad hash value in dynamic dispatch"); - gfc_add_expr_to_block (&body, tmp); - - /* Write the switch expression. */ - tmp = gfc_finish_block (&body); - tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE); - gfc_add_expr_to_block (&se->pre, tmp); - - tmp = build1_v (LABEL_EXPR, end_label); - gfc_add_expr_to_block (&se->pre, tmp); - - se->expr = declared; - return; -} - - static void conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tree tmp; - if (expr && expr->symtree - && expr->value.function.class_esym) - { - if (!sym->backend_decl) - sym->backend_decl = gfc_get_extern_function_decl (sym); - - tmp = sym->backend_decl; - - if (!POINTER_TYPE_P (TREE_TYPE (tmp))) - { - gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - } - - select_class_proc (se, expr->value.function.class_esym, - tmp, expr); - return; - } - if (gfc_is_proc_ptr_comp (expr, NULL)) tmp = get_proc_ptr_comp (expr); else if (sym->attr.dummy) @@ -2614,8 +2484,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, /* Remember the vtab corresponds to the derived type not to the class declared type. */ - vtab = gfc_find_derived_vtab (e->ts.u.derived); + vtab = gfc_find_derived_vtab (e->ts.u.derived, true); gcc_assert (vtab); + gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); @@ -4463,7 +4334,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!c->expr || cm->attr.allocatable) continue; - if (cm->ts.type == BT_CLASS) + if (cm->ts.type == BT_CLASS && !cm->attr.proc_pointer) { gfc_component *data; data = gfc_find_component (cm->ts.u.derived, "$data", true, true); @@ -4484,10 +4355,11 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL && strcmp (cm->name, "$extends") == 0) { + tree vtab; gfc_symbol *vtabs; vtabs = cm->initializer->symtree->n.sym; - val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); - CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab); } else { @@ -5579,6 +5451,103 @@ gfc_trans_assign (gfc_code * code) } +/* Generate code to assign typebound procedures to a derived vtab. */ +void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt, + gfc_symbol *vtab) +{ + gfc_component *cmp; + tree vtb; + tree ctree; + tree proc; + tree cond = NULL_TREE; + stmtblock_t body; + bool seen_extends; + + /* Point to the first procedure pointer. */ + cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true); + + seen_extends = (cmp != NULL); + + vtb = gfc_get_symbol_decl (vtab); + + if (seen_extends) + { + cmp = cmp->next; + if (!cmp) + return; + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + vtb, cmp->backend_decl, NULL_TREE); + cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree, + build_int_cst (TREE_TYPE (ctree), 0)); + } + else + { + cmp = vtab->ts.u.derived->components; + } + + gfc_init_block (&body); + for (; cmp; cmp = cmp->next) + { + gfc_symbol *target = NULL; + + /* Generic procedure - build its vtab. */ + if (cmp->ts.type == BT_DERIVED && !cmp->tb) + { + gfc_symbol *vt = cmp->ts.interface; + + if (vt == NULL) + { + /* Use association loses the interface. Obtain the vtab + by name instead. */ + char name[2 * GFC_MAX_SYMBOL_LEN + 8]; + sprintf (name, "vtab$%s$%s", vtab->ts.u.derived->name, + cmp->name); + gfc_find_symbol (name, vtab->ns, 0, &vt); + if (vt == NULL) + continue; + } + + gfc_trans_assign_vtab_procs (&body, dt, vt); + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + vtb, cmp->backend_decl, NULL_TREE); + proc = gfc_get_symbol_decl (vt); + proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc); + gfc_add_modify (&body, ctree, proc); + continue; + } + + /* This is required when typebound generic procedures are called + with derived type targets. The specific procedures do not get + added to the vtype, which remains "empty". */ + if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym) + target = cmp->tb->u.specific->n.sym; + else + { + gfc_symtree *st; + st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL); + if (st->n.tb && st->n.tb->u.specific) + target = st->n.tb->u.specific->n.sym; + } + + if (!target) + continue; + + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + vtb, cmp->backend_decl, NULL_TREE); + proc = gfc_get_symbol_decl (target); + proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc); + gfc_add_modify (&body, ctree, proc); + } + + proc = gfc_finish_block (&body); + + if (seen_extends) + proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location)); + + gfc_add_expr_to_block (block, proc); +} + + /* Translate an assignment to a CLASS object (pointer or ordinary assignment). */ @@ -5620,9 +5589,9 @@ gfc_trans_class_assign (gfc_code *code) { gfc_symbol *vtab; gfc_symtree *st; - vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived); + vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived, true); gcc_assert (vtab); - + gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab); rhs = gfc_get_expr (); rhs->expr_type = EXPR_VARIABLE; gfc_find_sym_tree (vtab->name, NULL, 1, &st); -- cgit v1.2.1 From 6fe110773dc4e0ff861a8e05ab53ead156686b35 Mon Sep 17 00:00:00 2001 From: jason Date: Thu, 6 May 2010 20:51:52 +0000 Subject: Add support for C++0x nullptr. gcc: * c-common.c (c_common_reswords): Add nullptr. * c-common.h: Add RID_NULLPTR. Reorganize C++0x rids. * dwarf2out.c (is_base_type): Handle NULLPTR_TYPE. (gen_type_die_with_usage): Likewise. * dbxout.c (dbxout_type): Likewise. * sdbout.c (plain_type_1): Likewise. gcc/cp: * cp-tree.def: Add NULLPTR_TYPE. * cp-tree.h: Add nullptr_node. (cp_tree_index): Add CPTI_NULLPTR. (SCALAR_TYPE_P): Add NULLPTR_TYPE. * call.c (null_ptr_cst_p): Handle nullptr. (standard_conversion): Likewise. (convert_arg_to_ellipsis): Likewise. * mangle.c (write_type): Likewise. * name-lookup.c (arg_assoc_type): Likewise. * parser.c (cp_parser_primary_expression): Likewise. * typeck.c (cp_build_binary_op): Likewise. (build_reinterpret_cast_1): Likewise. * error.c (dump_type): Likewise. (dump_type_prefix, dump_type_suffix): Likewise. * decl.c (cxx_init_decl_processing): Likewise. * cxx-pretty-print.c (pp_cxx_constant): Likewise. * cvt.c (ocp_convert): Likewise. * rtti.c (typeinfo_in_lib_p, emit_support_tinfos): Put nullptr_t tinfo in libsupc++. libstdc++-v3: * config/abi/pre/gnu.ver: Add typeinfo for decltype(nullptr). libiberty: * cp-demangle.c (cplus_demangle_builtin_types): Add nullptr. (cplus_demangle_type): Handle nullptr. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159131 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index dfd38cc7e77..47883e258bb 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3077,7 +3077,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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; + tree present, null_ptr, type; if (attr->allocatable && (fsym == NULL || !fsym->attr.allocatable)) @@ -3101,10 +3101,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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)); + null_ptr = 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); + present, null_ptr); } else { -- cgit v1.2.1 From bcc41e511c80b8b8aa549a438ffcac69481db979 Mon Sep 17 00:00:00 2001 From: janus Date: Sat, 15 May 2010 13:52:33 +0000 Subject: 2010-05-15 Janus Weil PR fortran/43207 PR fortran/43969 * gfortran.h (gfc_class_null_initializer): New prototype. * expr.c (gfc_class_null_initializer): New function to build a NULL initializer for CLASS pointers. * symbol.c (gfc_build_class_symbol): Modify internal naming of class containers. Remove default NULL initialization of $data component. * trans.c (gfc_allocate_array_with_status): Fix wording of an error message. * trans-expr.c (gfc_conv_initializer,gfc_trans_subcomponent_assign): Use new function 'gfc_class_null_initializer'. * trans-intrinsic.c (gfc_conv_allocated): Handle allocatable scalar class variables. 2010-05-15 Janus Weil PR fortran/43207 PR fortran/43969 * gfortran.dg/class_18.f03: New. * gfortran.dg/class_19.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159431 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 47883e258bb..4d48c05b7aa 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3894,7 +3894,10 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, case BT_DERIVED: case BT_CLASS: gfc_init_se (&se, NULL); - gfc_conv_structure (&se, expr, 1); + if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL) + gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1); + else + gfc_conv_structure (&se, expr, 1); return se.expr; case BT_CHARACTER: @@ -4202,7 +4205,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { /* NULL initialization for CLASS components. */ tmp = gfc_trans_structure_assign (dest, - gfc_default_initializer (&cm->ts)); + gfc_class_null_initializer (&cm->ts)); gfc_add_expr_to_block (&block, tmp); } else if (cm->attr.dimension) -- cgit v1.2.1 From 7c75339c4af0b37a67933ede0dccae3ca45623f8 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 17 May 2010 19:58:48 +0000 Subject: 2010-05-17 Janus Weil PR fortran/43990 * trans-expr.c (gfc_conv_structure): Remove unneeded and buggy code. This is now handled via 'gfc_class_null_initializer'. 2010-05-17 Janus Weil PR fortran/43990 * gfortran.dg/class_21.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159511 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 4d48c05b7aa..b7a296dc7a0 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4337,20 +4337,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!c->expr || cm->attr.allocatable) continue; - if (cm->ts.type == BT_CLASS && !cm->attr.proc_pointer) - { - gfc_component *data; - data = gfc_find_component (cm->ts.u.derived, "$data", true, true); - if (!data->backend_decl) - gfc_get_derived_type (cm->ts.u.derived); - val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (data->backend_decl), - data->attr.dimension, - data->attr.pointer); - - CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val); - } - else if (strcmp (cm->name, "$size") == 0) + if (strcmp (cm->name, "$size") == 0) { val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); -- cgit v1.2.1 From 989adef3b44d84f7b46c259ba46911460de87c51 Mon Sep 17 00:00:00 2001 From: steven Date: Thu, 20 May 2010 20:57:45 +0000 Subject: * trans-expr.c: Do not include convert.h, ggc.h, real.h, and gimple.h. (gfc_conv_string_tmp): Do not assert type comparibilty. * trans-array.c: Do not include gimple.h, ggc.h, and real.h. (gfc_conv_expr_descriptor): Remove assert. * trans-common.c: Clarify why rtl.h and tm.h are included. * trans-openmp.c: Do not include ggc.h and real.h. Explain why gimple.h is included. * trans-const.c: Do not include ggc.h. * trans-stmt.c: Do not include gimple.h, ggc.h, and real.h. * trans.c: Do not include ggc.h and real.h. Explain why gimple.h is included. * trans-types.c: Do not include tm.h. Explain why langhooks.h and dwarf2out.h are included. * trans-io.c: Do not include gimple.h and real.h. * trans-decl.c: Explain why gimple.h, tm.h, and rtl.h are included. * trans-intrinsic.c: Do not include gimple.h. Explain why tm.h is included. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159640 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 6 ------ 1 file changed, 6 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b7a296dc7a0..b76a3245d89 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -26,11 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "convert.h" -#include "ggc.h" #include "toplev.h" -#include "real.h" -#include "gimple.h" #include "langhooks.h" #include "flags.h" #include "gfortran.h" @@ -1115,8 +1111,6 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) tree var; tree tmp; - gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node)); - if (gfc_can_put_var_on_stack (len)) { /* Create a temporary variable to hold the result. */ -- cgit v1.2.1 From dca58d219480ce3c10fbc7442128ece6cc724d8f Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 23 May 2010 17:18:24 +0000 Subject: 2010-05-21 Tobias Burnus * gfortran.h: Do not include system.h. * bbt.c: Include system.h. * data.c: Ditto. * dependency.c: Ditto. * dump-parse-tree.c: Ditto. * arith.h: Do not include gfortran.h. * constructor.h: Do not include gfortran.h and splay-tree.h. * match.h: Do not include gfortran.h. * parse.h: Ditto. * target-memory.h: Ditto. * openmp.c: Do not include toplev.h and target.h. * trans-stmt.c: Ditto not include toplev.h. * primary.c: Ditto. * trans-common.c: Tell why toplev.h is needed. And do not include target.h. * trans-expr.c: Tell why toplev.h is needed. * trans-array.c: Ditto. * trans-openmp.c: Ditto. * trans-const.c: Ditto. * trans.c: Ditto. * trans-types.c: Ditto. * trans-io.c: Ditto. * trans-decl.c: Ditto. * scanner.c: Ditto. * convert.c: Ditto. * trans-intrinsic.c: Ditto. * options.c: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159763 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b76a3245d89..6c5c3286eb8 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -26,7 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "toplev.h" +#include "toplev.h" /* For fatal_error. */ #include "langhooks.h" #include "flags.h" #include "gfortran.h" -- cgit v1.2.1 From 750b874c85470db91ca50a0654cb3f85899d1e07 Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 11 Jun 2010 16:45:48 +0000 Subject: 2010-06-11 Paul Thomas PR fortran/42051 PR fortran/43896 * trans-expr.c (gfc_conv_derived_to_class): Handle array-valued functions with CLASS formal arguments. 2010-06-11 Paul Thomas PR fortran/42051 PR fortran/43896 * gfortran.dg/class_23.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160622 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 2 ++ 1 file changed, 2 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6c5c3286eb8..416e67d45cb 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2492,12 +2492,14 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, ss = gfc_walk_expr (e); if (ss == gfc_ss_terminator) { + parmse->ss = NULL; gfc_conv_expr_reference (parmse, e); tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); gfc_add_modify (&parmse->pre, ctree, tmp); } else { + parmse->ss = ss; gfc_conv_expr (parmse, e); gfc_add_modify (&parmse->pre, ctree, parmse->expr); } -- cgit v1.2.1 From b3c3927c05d8ad190b76c56ae6020e1650b85a97 Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 21 Jun 2010 14:15:56 +0000 Subject: 2010-06-20 Tobias Burnus PR fortran/40632 * interface.c (compare_parameter): Add gfc_is_simply_contiguous checks. * symbol.c (gfc_add_contiguous): New function. (gfc_copy_attr, check_conflict): Handle contiguous attribute. * decl.c (match_attr_spec): Ditto. (gfc_match_contiguous): New function. * resolve.c (resolve_fl_derived, resolve_symbol): Handle contiguous. * gfortran.h (symbol_attribute): Add contiguous. (gfc_is_simply_contiguous): Add prototype. (gfc_add_contiguous): Add prototype. * match.h (gfc_match_contiguous): Add prototype. * parse.c (decode_specification_statement, decode_statement): Handle contiguous attribute. * expr.c (gfc_is_simply_contiguous): New function. * dump-parse-tree.c (show_attr): Handle contiguous. * module.c (ab_attribute, attr_bits, mio_symbol_attribute): Ditto. * trans-expr.c (gfc_add_interface_mapping): Copy attr.contiguous. * trans-array.c (gfc_conv_descriptor_stride_get, gfc_conv_array_parameter): Handle contiguous arrays. * trans-types.c (gfc_build_array_type, gfc_build_array_type, gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info): Ditto. * trans.h (gfc_array_kind): Ditto. * trans-decl.c (gfc_get_symbol_decl): Ditto. 2010-06-20 Tobias Burnus PR fortran/40632 * gfortran.dg/contiguous_1.f90: New. * gfortran.dg/contiguous_2.f90: New. * gfortran.dg/contiguous_3.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161079 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 416e67d45cb..0164c163582 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1718,6 +1718,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, new_sym->as = gfc_copy_array_spec (sym->as); new_sym->attr.referenced = 1; new_sym->attr.dimension = sym->attr.dimension; + new_sym->attr.contiguous = sym->attr.contiguous; new_sym->attr.codimension = sym->attr.codimension; new_sym->attr.pointer = sym->attr.pointer; new_sym->attr.allocatable = sym->attr.allocatable; -- cgit v1.2.1 From 5d7ab965473e40d20b9db065754b4d9dd6869cf4 Mon Sep 17 00:00:00 2001 From: pault Date: Tue, 29 Jun 2010 18:57:43 +0000 Subject: 2010-06-29 Paul Thomas PR fortran/44582 * trans-expr.c (arrayfunc_assign_needs_temporary): New function to determine if a function assignment can be made without a temporary. (gfc_trans_arrayfunc_assign): Move all the conditions that suppress the direct function call to the above new functon and call it. 2010-06-29 Paul Thomas PR fortran/44582 * gfortran.dg/aliasing_array_result_1.f90 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161550 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 95 ++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 75 insertions(+), 20 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 0164c163582..692b3e2f846 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4870,41 +4870,40 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, } -/* Try to translate array(:) = func (...), where func is a transformational - array function, without using a temporary. Returns NULL is this isn't the - case. */ +/* There are quite a lot of restrictions on the optimisation in using an + array function assign without a temporary. */ -static tree -gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) +static bool +arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) { - gfc_se se; - gfc_ss *ss; gfc_ref * ref; bool seen_array_ref; bool c = false; - gfc_component *comp = NULL; + gfc_symbol *sym = expr1->symtree->n.sym; /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) - return NULL; + return true; - /* Elemental functions don't need a temporary anyway. */ + /* Elemental functions are scalarized so that they don't need a + temporary in gfc_trans_assignment_1, so return a true. Otherwise, + they would need special treatment in gfc_trans_arrayfunc_assign. */ if (expr2->value.function.esym != NULL && expr2->value.function.esym->attr.elemental) - return NULL; + return true; - /* Fail if rhs is not FULL or a contiguous section. */ + /* Need a temporary if rhs is not FULL or a contiguous section. */ if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c)) - return NULL; + return true; - /* Fail if EXPR1 can't be expressed as a descriptor. */ + /* Need a temporary if EXPR1 can't be expressed as a descriptor. */ if (gfc_ref_needs_temporary_p (expr1->ref)) - return NULL; + return true; /* Functions returning pointers need temporaries. */ if (expr2->symtree->n.sym->attr.pointer || expr2->symtree->n.sym->attr.allocatable) - return NULL; + return true; /* Character array functions need temporaries unless the character lengths are the same. */ @@ -4912,15 +4911,15 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) { if (expr1->ts.u.cl->length == NULL || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT) - return NULL; + return true; if (expr2->ts.u.cl->length == NULL || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT) - return NULL; + return true; if (mpz_cmp (expr1->ts.u.cl->length->value.integer, expr2->ts.u.cl->length->value.integer) != 0) - return NULL; + return true; } /* Check that no LHS component references appear during an array @@ -4934,7 +4933,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) if (ref->type == REF_ARRAY) seen_array_ref= true; else if (ref->type == REF_COMPONENT && seen_array_ref) - return NULL; + return true; } /* Check for a dependency. */ @@ -4942,6 +4941,62 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) expr2->value.function.esym, expr2->value.function.actual, NOT_ELEMENTAL)) + return true; + + /* If we have reached here with an intrinsic function, we do not + need a temporary. */ + if (expr2->value.function.isym) + return false; + + /* If the LHS is a dummy, we need a temporary if it is not + INTENT(OUT). */ + if (sym->attr.dummy && sym->attr.intent != INTENT_OUT) + return true; + + /* A PURE function can unconditionally be called without a temporary. */ + if (expr2->value.function.esym != NULL + && expr2->value.function.esym->attr.pure) + return false; + + /* TODO a function that could correctly be declared PURE but is not + could do with returning false as well. */ + + if (!sym->attr.use_assoc + && !sym->attr.in_common + && !sym->attr.pointer + && !sym->attr.target + && expr2->value.function.esym) + { + /* A temporary is not needed if the function is not contained and + the variable is local or host associated and not a pointer or + a target. */ + if (!expr2->value.function.esym->attr.contained) + return false; + + /* A temporary is not needed if the variable is local and not + a pointer, a target or a result. */ + if (sym->ns->parent + && expr2->value.function.esym->ns == sym->ns->parent) + return false; + } + + /* Default to temporary use. */ + return true; +} + + +/* Try to translate array(:) = func (...), where func is a transformational + array function, without using a temporary. Returns NULL if this isn't the + case. */ + +static tree +gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) +{ + gfc_se se; + gfc_ss *ss; + gfc_component *comp = NULL; + + if (arrayfunc_assign_needs_temporary (expr1, expr2)) return NULL; /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic -- cgit v1.2.1 From 008f96d836284b65ab4bc3ee81b62d2bd84ba452 Mon Sep 17 00:00:00 2001 From: froydnj Date: Mon, 5 Jul 2010 12:46:52 +0000 Subject: gcc/ * vec.h (VEC_splice, VEC_safe_splice): New macros. Add function implementations. gcc/fortran/ * trans.h (gfc_conv_procedure_call): Take a VEC instead of a tree. * trans-intrinsic.c (gfc_conv_intrinsic_funcall): Adjust for new type of gfc_conv_procedure_call. (conv_generic_with_optional_char_arg): Likewise. * trans-stmt.c (gfc_trans_call): Likewise. * trans-expr.c (gfc_conv_function_expr): Likewise. (gfc_conv_procedure_call): Use build_call_vec instead of build_call_list. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161834 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 53 ++++++++++++++++++++++++++---------------------- 1 file changed, 29 insertions(+), 24 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 692b3e2f846..1a7a4a1e4e2 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2653,7 +2653,6 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, return 0; } - /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -2662,11 +2661,11 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, int gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_actual_arglist * arg, gfc_expr * expr, - tree append_args) + VEC(tree,gc) *append_args) { gfc_interface_mapping mapping; - tree arglist; - tree retargs; + VEC(tree,gc) *arglist; + VEC(tree,gc) *retargs; tree tmp; tree fntype; gfc_se parmse; @@ -2677,7 +2676,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree type; tree var; tree len; - tree stringargs; + VEC(tree,gc) *stringargs; tree result = NULL; gfc_formal_arglist *formal; int has_alternate_specifier = 0; @@ -2690,10 +2689,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, stmtblock_t post; enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; gfc_component *comp = NULL; + int arglen; - arglist = NULL_TREE; - retargs = NULL_TREE; - stringargs = NULL_TREE; + arglist = NULL; + retargs = NULL; + stringargs = NULL; var = NULL_TREE; len = NULL_TREE; gfc_clear_ts (&ts); @@ -3136,9 +3136,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Character strings are passed as two parameters, a length and a pointer - except for Bind(c) which only passes the pointer. */ if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c) - stringargs = gfc_chainon_list (stringargs, parmse.string_length); + VEC_safe_push (tree, gc, stringargs, parmse.string_length); - arglist = gfc_chainon_list (arglist, parmse.expr); + VEC_safe_push (tree, gc, arglist, parmse.expr); } gfc_finish_interface_mapping (&mapping, &se->pre, &se->post); @@ -3160,7 +3160,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, For dummies, we have to look through the formal argument list for this function and use the character length found there.*/ if (!sym->attr.dummy) - cl.backend_decl = TREE_VALUE (stringargs); + cl.backend_decl = VEC_index (tree, stringargs, 0); else { formal = sym->ns->proc_name->formal; @@ -3213,7 +3213,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, result = build_fold_indirect_ref_loc (input_location, se->expr); - retargs = gfc_chainon_list (retargs, se->expr); + VEC_safe_push (tree, gc, retargs, se->expr); } else if (comp && comp->attr.dimension) { @@ -3237,7 +3237,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Pass the temporary as the first argument. */ result = info->descriptor; tmp = gfc_build_addr_expr (NULL_TREE, result); - retargs = gfc_chainon_list (retargs, tmp); + VEC_safe_push (tree, gc, retargs, tmp); } else if (!comp && sym->result->attr.dimension) { @@ -3261,7 +3261,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Pass the temporary as the first argument. */ result = info->descriptor; tmp = gfc_build_addr_expr (NULL_TREE, result); - retargs = gfc_chainon_list (retargs, tmp); + VEC_safe_push (tree, gc, retargs, tmp); } else if (ts.type == BT_CHARACTER) { @@ -3288,7 +3288,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else var = gfc_conv_string_tmp (se, type, len); - retargs = gfc_chainon_list (retargs, var); + VEC_safe_push (tree, gc, retargs, var); } else { @@ -3296,25 +3296,31 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, type = gfc_get_complex_type (ts.kind); var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx")); - retargs = gfc_chainon_list (retargs, var); + VEC_safe_push (tree, gc, retargs, var); } /* Add the string length to the argument list. */ if (ts.type == BT_CHARACTER) - retargs = gfc_chainon_list (retargs, len); + VEC_safe_push (tree, gc, retargs, len); } gfc_free_interface_mapping (&mapping); + /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */ + arglen = (VEC_length (tree, arglist) + + VEC_length (tree, stringargs) + VEC_length (tree, append_args)); + VEC_reserve_exact (tree, gc, retargs, arglen); + /* Add the return arguments. */ - arglist = chainon (retargs, arglist); + VEC_splice (tree, retargs, arglist); /* Add the hidden string length parameters to the arguments. */ - arglist = chainon (arglist, stringargs); + VEC_splice (tree, retargs, stringargs); /* We may want to append extra arguments here. This is used e.g. for calls to libgfortran_matmul_??, which need extra information. */ - if (append_args != NULL_TREE) - arglist = chainon (arglist, append_args); + if (!VEC_empty (tree, append_args)) + VEC_splice (tree, retargs, append_args); + arglist = retargs; /* Generate the actual call. */ conv_function_val (se, sym, expr); @@ -3338,7 +3344,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } fntype = TREE_TYPE (TREE_TYPE (se->expr)); - se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist); + se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist); /* If we have a pointer function, but we don't want a pointer, e.g. something like @@ -3786,8 +3792,7 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr) if (!sym) sym = expr->symtree->n.sym; - gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, - NULL_TREE); + gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL); } -- cgit v1.2.1 From 7cbc820e16a5c752351dd7db7150b2f128bc21e1 Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Jul 2010 19:57:29 +0000 Subject: 2010-07-06 Tobias Burnus * trans-decl.c: Include diagnostic-core.h besides toplev.h. * trans-intrinsic.c: Ditto. * trans-types.c: Ditto. * convert.c: Include diagnostic-core.h instead of toplev.h. * options.c: Ditto. * trans-array.c: Ditto. * trans-const.c: Ditto. * trans-expr.c: Ditto. * trans-io.c: Ditto. * trans-openmp.c: Ditto. * trans.c: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161885 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1a7a4a1e4e2..ea8b8920279 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -26,7 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "toplev.h" /* For fatal_error. */ +#include "diagnostic-core.h" /* For fatal_error. */ #include "langhooks.h" #include "flags.h" #include "gfortran.h" -- cgit v1.2.1 From e20c5d834d5edde630d46ea1e1bc5cb6f673f3bd Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 10 Jul 2010 14:57:25 +0000 Subject: 2010-07-10 Paul Thomas PR fortran/44773 * trans-expr.c (arrayfunc_assign_needs_temporary): No temporary if the lhs has never been host associated, as well as not being use associated, a pointer or a target. * resolve.c (resolve_variable): Mark variables that are host associated. * gfortran.h: Add the host_assoc bit to the symbol_attribute structure. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162038 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index ea8b8920279..5f2eda29693 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4978,6 +4978,11 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) if (!expr2->value.function.esym->attr.contained) return false; + /* A temporary is not needed if the lhs has never been host + associated and the procedure is contained. */ + else if (!sym->attr.host_assoc) + return false; + /* A temporary is not needed if the variable is local and not a pointer, a target or a result. */ if (sym->ns->parent -- cgit v1.2.1 From 09276310eee7ca1b0205abdb47fc612bec7ba51d Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 13 Jul 2010 06:57:17 +0000 Subject: 2010-07-13 Janus Weil PR fortran/44434 PR fortran/44565 PR fortran/43945 PR fortran/44869 * gfortran.h (gfc_find_derived_vtab): Modified prototype. * class.c (gfc_build_class_symbol): Modified call to 'gfc_find_derived_vtab'. (add_proc_component): Removed, moved code into 'add_proc_comp'. (add_proc_comps): Renamed to 'add_proc_comp', removed treatment of generics. (add_procs_to_declared_vtab1): Removed unnecessary argument 'resolved'. Removed treatment of generics. (copy_vtab_proc_comps): Removed unnecessary argument 'resolved'. Call 'add_proc_comp' instead of duplicating code. (add_procs_to_declared_vtab): Removed unnecessary arguments 'resolved' and 'declared'. (add_generic_specifics,add_generics_to_declared_vtab): Removed. (gfc_find_derived_vtab): Removed unnecessary argument 'resolved'. Removed treatment of generics. * iresolve.c (gfc_resolve_extends_type_of): Modified call to 'gfc_find_derived_vtab'. * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): Removed treatment of generics. (resolve_select_type,resolve_fl_derived): Modified call to 'gfc_find_derived_vtab'. * trans-decl.c (gfc_get_symbol_decl): Ditto. * trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign): Ditto. * trans-stmt.c (gfc_trans_allocate): Ditto. 2010-07-13 Janus Weil PR fortran/44434 PR fortran/44565 PR fortran/43945 PR fortran/44869 * gfortran.dg/dynamic_dispatch_1.f03: Fixed invalid test case. * gfortran.dg/dynamic_dispatch_2.f03: Ditto. * gfortran.dg/dynamic_dispatch_3.f03: Ditto. * gfortran.dh/typebound_call_16.f03: New. * gfortran.dg/typebound_generic_6.f03: New. * gfortran.dg/typebound_generic_7.f03: New. * gfortran.dg/typebound_generic_8.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162125 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 5f2eda29693..ff250fdbfee 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2478,8 +2478,8 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, var, cmp->backend_decl, NULL_TREE); /* Remember the vtab corresponds to the derived type - not to the class declared type. */ - vtab = gfc_find_derived_vtab (e->ts.u.derived, true); + not to the class declared type. */ + vtab = gfc_find_derived_vtab (e->ts.u.derived); gcc_assert (vtab); gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); @@ -5641,7 +5641,7 @@ gfc_trans_class_assign (gfc_code *code) { gfc_symbol *vtab; gfc_symtree *st; - vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived, true); + vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived); gcc_assert (vtab); gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab); rhs = gfc_get_expr (); -- cgit v1.2.1 From 7f7b3f75f58eb5503a61f3a195e55211e03a2f73 Mon Sep 17 00:00:00 2001 From: jakub Date: Tue, 13 Jul 2010 22:56:29 +0000 Subject: * trans-expr.c (string_to_single_character): Also optimize string literals containing a single char followed only by spaces. (gfc_trans_string_copy): Remove redundant string_to_single_character calls. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162161 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 44 +++++++++++++++++++++++++++++++++----------- 1 file changed, 33 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index ff250fdbfee..9857f4459e5 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1393,12 +1393,40 @@ string_to_single_character (tree len, tree str, int kind) { gcc_assert (POINTER_TYPE_P (TREE_TYPE (str))); - if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1 - && TREE_INT_CST_HIGH (len) == 0) + if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0) + return NULL_TREE; + + if (TREE_INT_CST_LOW (len) == 1) { str = fold_convert (gfc_get_pchar_type (kind), str); - return build_fold_indirect_ref_loc (input_location, - str); + return build_fold_indirect_ref_loc (input_location, str); + } + + if (kind == 1 + && TREE_CODE (str) == ADDR_EXPR + && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF + && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST + && array_ref_low_bound (TREE_OPERAND (str, 0)) + == TREE_OPERAND (TREE_OPERAND (str, 0), 1) + && TREE_INT_CST_LOW (len) > 1 + && TREE_INT_CST_LOW (len) + == (unsigned HOST_WIDE_INT) + TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0))) + { + tree ret = fold_convert (gfc_get_pchar_type (kind), str); + ret = build_fold_indirect_ref_loc (input_location, ret); + if (TREE_CODE (ret) == INTEGER_CST) + { + tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0); + int i, len = TREE_STRING_LENGTH (string_cst); + const char *ptr = TREE_STRING_POINTER (string_cst); + + for (i = 1; i < len; i++) + if (ptr[i] != ' ') + return NULL_TREE; + + return ret; + } } return NULL_TREE; @@ -3556,7 +3584,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, if (dlength != NULL_TREE) { dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); - dsc = string_to_single_character (slen, dest, dkind); + dsc = string_to_single_character (dlen, dest, dkind); } else { @@ -3564,12 +3592,6 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, dsc = dest; } - if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src))) - ssc = string_to_single_character (slen, src, skind); - if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest))) - dsc = string_to_single_character (dlen, dest, dkind); - - /* Assign directly if the types are compatible. */ if (dsc != NULL_TREE && ssc != NULL_TREE && TREE_TYPE (dsc) == TREE_TYPE (ssc)) -- cgit v1.2.1 From a313dc3abdf97695829cadd1e721499e3016b2e7 Mon Sep 17 00:00:00 2001 From: jakub Date: Thu, 15 Jul 2010 07:50:04 +0000 Subject: * trans.h (gfc_build_compare_string): Add CODE argument. * trans-intrinsic.c (gfc_conv_intrinsic_strcmp): Pass OP to gfc_build_compare_string. * trans-expr.c (gfc_conv_expr_op): Pass CODE to gfc_build_compare_string. (string_to_single_character): Rename len variable to length. (gfc_optimize_len_trim): New function. (gfc_build_compare_string): Add CODE argument. If it is EQ_EXPR or NE_EXPR and one of the strings is string literal with LEN_TRIM bigger than the length of the other string, they compare unequal. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162208 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 85 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 65 insertions(+), 20 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 9857f4459e5..02cc241802b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1365,7 +1365,8 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) lse.expr = gfc_build_compare_string (lse.string_length, lse.expr, rse.string_length, rse.expr, - expr->value.op.op1->ts.kind); + expr->value.op.op1->ts.kind, + code); rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0); gfc_add_block_to_block (&lse.post, &rse.post); } @@ -1418,10 +1419,10 @@ string_to_single_character (tree len, tree str, int kind) if (TREE_CODE (ret) == INTEGER_CST) { tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0); - int i, len = TREE_STRING_LENGTH (string_cst); + int i, length = TREE_STRING_LENGTH (string_cst); const char *ptr = TREE_STRING_POINTER (string_cst); - for (i = 1; i < len; i++) + for (i = 1; i < length; i++) if (ptr[i] != ' ') return NULL_TREE; @@ -1494,16 +1495,51 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) } } +/* Helper function for gfc_build_compare_string. Return LEN_TRIM value + if STR is a string literal, otherwise return -1. */ + +static int +gfc_optimize_len_trim (tree len, tree str, int kind) +{ + if (kind == 1 + && TREE_CODE (str) == ADDR_EXPR + && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF + && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST + && array_ref_low_bound (TREE_OPERAND (str, 0)) + == TREE_OPERAND (TREE_OPERAND (str, 0), 1) + && TREE_INT_CST_LOW (len) >= 1 + && TREE_INT_CST_LOW (len) + == (unsigned HOST_WIDE_INT) + TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0))) + { + tree folded = fold_convert (gfc_get_pchar_type (kind), str); + folded = build_fold_indirect_ref_loc (input_location, folded); + if (TREE_CODE (folded) == INTEGER_CST) + { + tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0); + int length = TREE_STRING_LENGTH (string_cst); + const char *ptr = TREE_STRING_POINTER (string_cst); + + for (; length > 0; length--) + if (ptr[length - 1] != ' ') + break; + + return length; + } + } + return -1; +} /* Compare two strings. If they are all single characters, the result is the subtraction of them. Otherwise, we build a library call. */ tree -gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) +gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind, + enum tree_code code) { tree sc1; tree sc2; - tree tmp; + tree fndecl; gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); @@ -1516,25 +1552,34 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) /* Deal with single character specially. */ sc1 = fold_convert (integer_type_node, sc1); sc2 = fold_convert (integer_type_node, sc2); - tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2); + return fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2); } - else - { - /* Build a call for the comparison. */ - tree fndecl; - if (kind == 1) - fndecl = gfor_fndecl_compare_string; - else if (kind == 4) - fndecl = gfor_fndecl_compare_string_char4; - else - gcc_unreachable (); - - tmp = build_call_expr_loc (input_location, - fndecl, 4, len1, str1, len2, str2); + if ((code == EQ_EXPR || code == NE_EXPR) + && optimize + && INTEGER_CST_P (len1) && INTEGER_CST_P (len2)) + { + /* If one string is a string literal with LEN_TRIM longer + than the length of the second string, the strings + compare unequal. */ + int len = gfc_optimize_len_trim (len1, str1, kind); + if (len > 0 && compare_tree_int (len2, len) < 0) + return integer_one_node; + len = gfc_optimize_len_trim (len2, str2, kind); + if (len > 0 && compare_tree_int (len1, len) < 0) + return integer_one_node; } - return tmp; + /* Build a call for the comparison. */ + if (kind == 1) + fndecl = gfor_fndecl_compare_string; + else if (kind == 4) + fndecl = gfor_fndecl_compare_string_char4; + else + gcc_unreachable (); + + return build_call_expr_loc (input_location, fndecl, 4, + len1, str1, len2, str2); } -- cgit v1.2.1 From d04cac57d09d68adcb5a5a50552ec694310c76a2 Mon Sep 17 00:00:00 2001 From: jakub Date: Thu, 15 Jul 2010 16:09:48 +0000 Subject: * trans.h (gfc_string_to_single_character): New prototype. * trans-expr.c (string_to_single_character): Renamed to ... (gfc_string_to_single_character): ... this. No longer static. (gfc_conv_scalar_char_value, gfc_build_compare_string, gfc_trans_string_copy): Adjust callers. * config-lang.in (gtfiles): Add fortran/trans-stmt.c. * trans-stmt.c: Include ggc.h and gt-fortran-trans-stmt.h. (select_struct): Move to toplevel, add GTY(()). (gfc_trans_character_select): Optimize SELECT CASE with character length 1. * gfortran.dg/select_char_2.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162226 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 02cc241802b..09ad110ff48 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1389,8 +1389,8 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) /* If a string's length is one, we convert it to a single character. */ -static tree -string_to_single_character (tree len, tree str, int kind) +tree +gfc_string_to_single_character (tree len, tree str, int kind) { gcc_assert (POINTER_TYPE_P (TREE_TYPE (str))); @@ -1475,7 +1475,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) { if ((*expr)->ref == NULL) { - se->expr = string_to_single_character + se->expr = gfc_string_to_single_character (build_int_cst (integer_type_node, 1), gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), gfc_get_symbol_decl @@ -1485,7 +1485,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) else { gfc_conv_variable (se, *expr); - se->expr = string_to_single_character + se->expr = gfc_string_to_single_character (build_int_cst (integer_type_node, 1), gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), se->expr), @@ -1544,8 +1544,8 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind, gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); - sc1 = string_to_single_character (len1, str1, kind); - sc2 = string_to_single_character (len2, str2, kind); + sc1 = gfc_string_to_single_character (len1, str1, kind); + sc2 = gfc_string_to_single_character (len2, str2, kind); if (sc1 != NULL_TREE && sc2 != NULL_TREE) { @@ -3618,7 +3618,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, if (slength != NULL_TREE) { slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); - ssc = string_to_single_character (slen, src, skind); + ssc = gfc_string_to_single_character (slen, src, skind); } else { @@ -3629,7 +3629,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, if (dlength != NULL_TREE) { dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); - dsc = string_to_single_character (dlen, dest, dkind); + dsc = gfc_string_to_single_character (dlen, dest, dkind); } else { -- cgit v1.2.1 From 25f9f93d9623117368f63ab9001ef2703c454d85 Mon Sep 17 00:00:00 2001 From: pault Date: Fri, 23 Jul 2010 14:25:55 +0000 Subject: 2009-07-23 Paul Thomas PR fortran/24524 * trans-array.c (gfc_init_loopinfo): Initialize the reverse field. gfc_trans_scalarized_loop_end: If reverse set in dimension n, reverse the scalarization loop. gfc_conv_resolve_dependencies: Pass the reverse field of the loopinfo to gfc_dep_resolver. trans-expr.c (gfc_trans_assignment_1): Enable loop reversal for assignment by resetting loop.reverse. gfortran.h : Add the gfc_reverse enum. trans.h : Add the reverse field to gfc_loopinfo. dependency.c (gfc_check_dependency): Pass null to the new arg of gfc_dep_resolver. (gfc_check_section_vs_section): Check for reverse dependencies. (gfc_dep_resolver): Add reverse argument and deal with the loop reversal logic. dependency.h : Modify prototype for gfc_dep_resolver to include gfc_reverse *. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162462 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 09ad110ff48..a83d4b3eda4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5303,6 +5303,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, bool l_is_temp; bool scalar_to_array; tree string_length; + int n; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -5348,6 +5349,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Calculate the bounds of the scalarization. */ gfc_conv_ss_startstride (&loop); + /* Enable loop reversal. */ + for (n = 0; n < loop.dimen; n++) + loop.reverse[n] = GFC_REVERSE_NOT_SET; /* Resolve any data dependencies in the statement. */ gfc_conv_resolve_dependencies (&loop, lss, rss); /* Setup the scalarizing loops. */ -- cgit v1.2.1