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-array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index cf38fc371be..ce9114f250c 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5008,7 +5008,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) else if (se->direct_byref) full = 0; else - full = gfc_full_array_ref_p (info->ref); + full = gfc_full_array_ref_p (info->ref, NULL); if (full) { -- cgit v1.2.1 From f19c25b816c3867ae1f01a47f10e5ec31f5eecda Mon Sep 17 00:00:00 2001 From: matz Date: Thu, 2 Jul 2009 15:31:28 +0000 Subject: fortran/ PR fortran/32131 * trans-array.c (gfc_conv_descriptor_stride_get): Return constant one for strides in the first dimension of ALLOCATABLE arrays. testsuite/ PR fortran/32131 * gfortran.dg/pr32921.f: Adjust. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149178 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ce9114f250c..4b832cf8832 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -284,6 +284,12 @@ gfc_conv_descriptor_stride (tree desc, tree dim) tree gfc_conv_descriptor_stride_get (tree desc, tree dim) { + tree type = TREE_TYPE (desc); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + if (integer_zerop (dim) + && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) + return gfc_index_one_node; + return gfc_conv_descriptor_stride (desc, dim); } -- 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-array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 4b832cf8832..32858a7abcd 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6366,7 +6366,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) sym = expr->symtree->n.sym; /* A function that returns arrays. */ - is_proc_ptr_comp (expr, &comp); + gfc_is_proc_ptr_comp (expr, &comp); if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) || (comp && comp->attr.dimension)) { -- 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-array.c | 78 +++++++++++++++++++++++++++++++---------------- 1 file changed, 52 insertions(+), 26 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 32858a7abcd..270835556ba 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -620,11 +620,13 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc))); packed = gfc_create_var (build_pointer_type (tmp), "data"); - tmp = build_call_expr (gfor_fndecl_in_pack, 1, initial); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_in_pack, 1, initial); tmp = fold_convert (TREE_TYPE (packed), tmp); gfc_add_modify (pre, packed, tmp); - tmp = build_fold_indirect_ref (initial); + tmp = build_fold_indirect_ref_loc (input_location, + initial); source_data = gfc_conv_descriptor_data_get (tmp); /* internal_pack may return source->data without any allocation @@ -1084,7 +1086,8 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, gfc_conv_expr (se, expr); /* Store the value. */ - tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc)); + tmp = build_fold_indirect_ref_loc (input_location, + gfc_conv_descriptor_data_get (desc)); tmp = gfc_build_array_ref (tmp, offset, NULL); if (expr->ts.type == BT_CHARACTER) @@ -1353,14 +1356,16 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, /* Use BUILTIN_MEMCPY to assign the values. */ tmp = gfc_conv_descriptor_data_get (desc); - tmp = build_fold_indirect_ref (tmp); + tmp = build_fold_indirect_ref_loc (input_location, + tmp); tmp = gfc_build_array_ref (tmp, *poffset, NULL); tmp = gfc_build_addr_expr (NULL_TREE, tmp); init = gfc_build_addr_expr (NULL_TREE, init); size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type)); bound = build_int_cst (NULL_TREE, n * size); - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMCPY], 3, tmp, init, bound); gfc_add_expr_to_block (&body, tmp); @@ -2408,7 +2413,8 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, index, gfc_conv_array_stride (desc, 0)); /* Read the vector to get an index into info->descriptor. */ - data = build_fold_indirect_ref (gfc_conv_array_data (desc)); + data = build_fold_indirect_ref_loc (input_location, + gfc_conv_array_data (desc)); index = gfc_build_array_ref (data, index, NULL); index = gfc_evaluate_now (index, &se->pre); @@ -2482,7 +2488,8 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) if (se->ss->expr && is_subref_array (se->ss->expr)) decl = se->ss->expr->symtree->n.sym->backend_decl; - tmp = build_fold_indirect_ref (info->data); + tmp = build_fold_indirect_ref_loc (input_location, + info->data); se->expr = gfc_build_array_ref (tmp, index, decl); } @@ -4461,7 +4468,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) type = TREE_TYPE (tmpdesc); gcc_assert (GFC_ARRAY_TYPE_P (type)); dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - dumdesc = build_fold_indirect_ref (dumdesc); + dumdesc = build_fold_indirect_ref_loc (input_location, + dumdesc); gfc_start_block (&block); if (sym->ts.type == BT_CHARACTER @@ -4513,7 +4521,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0))); /* A library call to repack the array if necessary. */ tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp); + stmt_unpacked = build_call_expr_loc (input_location, + gfor_fndecl_in_pack, 1, tmp); stride = gfc_index_one_node; @@ -4699,7 +4708,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) if (sym->attr.intent != INTENT_IN) { /* Copy the data back. */ - tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc); gfc_add_expr_to_block (&cleanup, tmp); } @@ -4710,7 +4720,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) stmt = gfc_finish_block (&cleanup); /* Only do the cleanup if the array was repacked. */ - tmp = build_fold_indirect_ref (dumdesc); + tmp = build_fold_indirect_ref_loc (input_location, + dumdesc); tmp = gfc_conv_descriptor_data_get (tmp); tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc); stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); @@ -4753,7 +4764,8 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, } tmp = gfc_conv_array_data (desc); - tmp = build_fold_indirect_ref (tmp); + tmp = build_fold_indirect_ref_loc (input_location, + tmp); tmp = gfc_build_array_ref (tmp, offset, NULL); /* Offset the data pointer for pointer assignments from arrays with @@ -5178,7 +5190,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) { gfc_conv_expr (&rse, expr); if (POINTER_TYPE_P (TREE_TYPE (rse.expr))) - rse.expr = build_fold_indirect_ref (rse.expr); + rse.expr = build_fold_indirect_ref_loc (input_location, + rse.expr); } else gfc_conv_expr_val (&rse, expr); @@ -5408,7 +5421,8 @@ array_parameter_size (tree desc, gfc_expr *expr, tree *size) if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); else if (expr->rank > 1) - *size = build_call_expr (gfor_fndecl_size0, 1, + *size = build_call_expr_loc (input_location, + gfor_fndecl_size0, 1, gfc_build_addr_expr (NULL, desc)); else { @@ -5509,7 +5523,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))) - se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr)); + se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location, + se->expr)); return; } @@ -5519,7 +5534,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, se->want_pointer = 1; gfc_conv_expr_descriptor (se, expr, ss); if (size) - array_parameter_size (build_fold_indirect_ref (se->expr), + array_parameter_size (build_fold_indirect_ref_loc (input_location, + se->expr), expr, size); } @@ -5529,7 +5545,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, && expr->ts.derived->attr.alloc_comp && expr->expr_type != EXPR_VARIABLE) { - tmp = build_fold_indirect_ref (se->expr); + tmp = build_fold_indirect_ref_loc (input_location, + se->expr); tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank); gfc_add_expr_to_block (&se->post, tmp); } @@ -5548,7 +5565,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, gfc_warning ("Creating array temporary at %L", &expr->where); } - ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc); + ptr = build_call_expr_loc (input_location, + gfor_fndecl_in_pack, 1, desc); if (fsym && fsym->attr.optional && sym && sym->attr.optional) { @@ -5572,7 +5590,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, else asprintf (&msg, "An array temporary was created"); - tmp = build_fold_indirect_ref (desc); + tmp = build_fold_indirect_ref_loc (input_location, + desc); tmp = gfc_conv_array_data (tmp); tmp = fold_build2 (NE_EXPR, boolean_type_node, fold_convert (TREE_TYPE (tmp), ptr), tmp); @@ -5591,7 +5610,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, /* Copy the data back. */ if (fsym == NULL || fsym->attr.intent != INTENT_IN) { - tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_in_unpack, 2, desc, ptr); gfc_add_expr_to_block (&block, tmp); } @@ -5604,7 +5624,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, gfc_init_block (&block); /* Only if it was repacked. This code needs to be executed before the loop cleanup code. */ - tmp = build_fold_indirect_ref (desc); + tmp = build_fold_indirect_ref_loc (input_location, + desc); tmp = gfc_conv_array_data (tmp); tmp = fold_build2 (NE_EXPR, boolean_type_node, fold_convert (TREE_TYPE (tmp), ptr), tmp); @@ -5707,7 +5728,8 @@ gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank) /* We know the temporary and the value will be the same length, so can use memcpy. */ tmp = built_in_decls[BUILT_IN_MEMCPY]; - tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest), + tmp = build_call_expr_loc (input_location, + tmp, 3, gfc_conv_descriptor_data_get (dest), gfc_conv_descriptor_data_get (src), size); gfc_add_expr_to_block (&block, tmp); tmp = gfc_finish_block (&block); @@ -5750,7 +5772,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_init_block (&fnblock); if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref (decl); + decl = build_fold_indirect_ref_loc (input_location, + decl); /* If this an array of derived types with allocatable components build a loop and recursively call this function. */ @@ -5758,7 +5781,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) { tmp = gfc_conv_array_data (decl); - var = build_fold_indirect_ref (tmp); + var = build_fold_indirect_ref_loc (input_location, + tmp); /* Get the number of elements - 1 and set the counter. */ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) @@ -5797,7 +5821,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank); gfc_add_expr_to_block (&fnblock, tmp); } - tmp = build_fold_indirect_ref (gfc_conv_array_data (dest)); + tmp = build_fold_indirect_ref_loc (input_location, + gfc_conv_array_data (dest)); dref = gfc_build_array_ref (tmp, index, NULL); tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose); } @@ -6022,7 +6047,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) { /* If the backend_decl is not a descriptor, we must have a pointer to one. */ - descriptor = build_fold_indirect_ref (sym->backend_decl); + descriptor = build_fold_indirect_ref_loc (input_location, + sym->backend_decl); type = TREE_TYPE (descriptor); } -- cgit v1.2.1 From 7ebee93316c8eef52171ea24d7386294d72fa367 Mon Sep 17 00:00:00 2001 From: jakub Date: Fri, 24 Jul 2009 07:57:13 +0000 Subject: PR fortran/40643 PR fortran/31067 * trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_minmaxval): Handle Infinities and NaNs properly, optimize. * trans-array.c (gfc_trans_scalarized_loop_end): No longer static. * trans-array.h (gfc_trans_scalarized_loop_end): New prototype. * libgfortran.h (GFC_REAL_4_INFINITY, GFC_REAL_8_INFINITY, GFC_REAL_10_INFINITY, GFC_REAL_16_INFINITY, GFC_REAL_4_QUIET_NAN, GFC_REAL_8_QUIET_NAN, GFC_REAL_10_QUIET_NAN, GFC_REAL_16_QUIET_NAN): Define. * m4/iparm.m4 (atype_inf, atype_nan): Define. * m4/ifunction.m4: Formatting. * m4/iforeach.m4: Likewise. (START_FOREACH_FUNCTION): Initialize dest to all 1s, not all 0s. (START_FOREACH_BLOCK, FINISH_FOREACH_FUNCTION, FINISH_MASKED_FOREACH_FUNCTION): Run foreach block inside a loop until count[0] == extent[0]. * m4/minval.m4: Formatting. Handle NaNs and infinities. Optimize. * m4/maxval.m4: Likewise. * m4/minloc0.m4: Likewise. * m4/maxloc0.m4: Likewise. * m4/minloc1.m4: Likewise. * m4/maxloc1.m4: Likewise. * generated/maxloc0_16_i16.c: Regenerated. * generated/maxloc0_16_i1.c: Likewise. * generated/maxloc0_16_i2.c: Likewise. * generated/maxloc0_16_i4.c: Likewise. * generated/maxloc0_16_i8.c: Likewise. * generated/maxloc0_16_r10.c: Likewise. * generated/maxloc0_16_r16.c: Likewise. * generated/maxloc0_16_r4.c: Likewise. * generated/maxloc0_16_r8.c: Likewise. * generated/maxloc0_4_i16.c: Likewise. * generated/maxloc0_4_i1.c: Likewise. * generated/maxloc0_4_i2.c: Likewise. * generated/maxloc0_4_i4.c: Likewise. * generated/maxloc0_4_i8.c: Likewise. * generated/maxloc0_4_r10.c: Likewise. * generated/maxloc0_4_r16.c: Likewise. * generated/maxloc0_4_r4.c: Likewise. * generated/maxloc0_4_r8.c: Likewise. * generated/maxloc0_8_i16.c: Likewise. * generated/maxloc0_8_i1.c: Likewise. * generated/maxloc0_8_i2.c: Likewise. * generated/maxloc0_8_i4.c: Likewise. * generated/maxloc0_8_i8.c: Likewise. * generated/maxloc0_8_r10.c: Likewise. * generated/maxloc0_8_r16.c: Likewise. * generated/maxloc0_8_r4.c: Likewise. * generated/maxloc0_8_r8.c: Likewise. * generated/maxloc1_16_i16.c: Likewise. * generated/maxloc1_16_i1.c: Likewise. * generated/maxloc1_16_i2.c: Likewise. * generated/maxloc1_16_i4.c: Likewise. * generated/maxloc1_16_i8.c: Likewise. * generated/maxloc1_16_r10.c: Likewise. * generated/maxloc1_16_r16.c: Likewise. * generated/maxloc1_16_r4.c: Likewise. * generated/maxloc1_16_r8.c: Likewise. * generated/maxloc1_4_i16.c: Likewise. * generated/maxloc1_4_i1.c: Likewise. * generated/maxloc1_4_i2.c: Likewise. * generated/maxloc1_4_i4.c: Likewise. * generated/maxloc1_4_i8.c: Likewise. * generated/maxloc1_4_r10.c: Likewise. * generated/maxloc1_4_r16.c: Likewise. * generated/maxloc1_4_r4.c: Likewise. * generated/maxloc1_4_r8.c: Likewise. * generated/maxloc1_8_i16.c: Likewise. * generated/maxloc1_8_i1.c: Likewise. * generated/maxloc1_8_i2.c: Likewise. * generated/maxloc1_8_i4.c: Likewise. * generated/maxloc1_8_i8.c: Likewise. * generated/maxloc1_8_r10.c: Likewise. * generated/maxloc1_8_r16.c: Likewise. * generated/maxloc1_8_r4.c: Likewise. * generated/maxloc1_8_r8.c: Likewise. * generated/maxval_i16.c: Likewise. * generated/maxval_i1.c: Likewise. * generated/maxval_i2.c: Likewise. * generated/maxval_i4.c: Likewise. * generated/maxval_i8.c: Likewise. * generated/maxval_r10.c: Likewise. * generated/maxval_r16.c: Likewise. * generated/maxval_r4.c: Likewise. * generated/maxval_r8.c: Likewise. * generated/minloc0_16_i16.c: Likewise. * generated/minloc0_16_i1.c: Likewise. * generated/minloc0_16_i2.c: Likewise. * generated/minloc0_16_i4.c: Likewise. * generated/minloc0_16_i8.c: Likewise. * generated/minloc0_16_r10.c: Likewise. * generated/minloc0_16_r16.c: Likewise. * generated/minloc0_16_r4.c: Likewise. * generated/minloc0_16_r8.c: Likewise. * generated/minloc0_4_i16.c: Likewise. * generated/minloc0_4_i1.c: Likewise. * generated/minloc0_4_i2.c: Likewise. * generated/minloc0_4_i4.c: Likewise. * generated/minloc0_4_i8.c: Likewise. * generated/minloc0_4_r10.c: Likewise. * generated/minloc0_4_r16.c: Likewise. * generated/minloc0_4_r4.c: Likewise. * generated/minloc0_4_r8.c: Likewise. * generated/minloc0_8_i16.c: Likewise. * generated/minloc0_8_i1.c: Likewise. * generated/minloc0_8_i2.c: Likewise. * generated/minloc0_8_i4.c: Likewise. * generated/minloc0_8_i8.c: Likewise. * generated/minloc0_8_r10.c: Likewise. * generated/minloc0_8_r16.c: Likewise. * generated/minloc0_8_r4.c: Likewise. * generated/minloc0_8_r8.c: Likewise. * generated/minloc1_16_i16.c: Likewise. * generated/minloc1_16_i1.c: Likewise. * generated/minloc1_16_i2.c: Likewise. * generated/minloc1_16_i4.c: Likewise. * generated/minloc1_16_i8.c: Likewise. * generated/minloc1_16_r10.c: Likewise. * generated/minloc1_16_r16.c: Likewise. * generated/minloc1_16_r4.c: Likewise. * generated/minloc1_16_r8.c: Likewise. * generated/minloc1_4_i16.c: Likewise. * generated/minloc1_4_i1.c: Likewise. * generated/minloc1_4_i2.c: Likewise. * generated/minloc1_4_i4.c: Likewise. * generated/minloc1_4_i8.c: Likewise. * generated/minloc1_4_r10.c: Likewise. * generated/minloc1_4_r16.c: Likewise. * generated/minloc1_4_r4.c: Likewise. * generated/minloc1_4_r8.c: Likewise. * generated/minloc1_8_i16.c: Likewise. * generated/minloc1_8_i1.c: Likewise. * generated/minloc1_8_i2.c: Likewise. * generated/minloc1_8_i4.c: Likewise. * generated/minloc1_8_i8.c: Likewise. * generated/minloc1_8_r10.c: Likewise. * generated/minloc1_8_r16.c: Likewise. * generated/minloc1_8_r4.c: Likewise. * generated/minloc1_8_r8.c: Likewise. * generated/minval_i16.c: Likewise. * generated/minval_i1.c: Likewise. * generated/minval_i2.c: Likewise. * generated/minval_i4.c: Likewise. * generated/minval_i8.c: Likewise. * generated/minval_r10.c: Likewise. * generated/minval_r16.c: Likewise. * generated/minval_r4.c: Likewise. * generated/minval_r8.c: Likewise. * generated/product_c10.c: Likewise. * generated/product_c16.c: Likewise. * generated/product_c4.c: Likewise. * generated/product_c8.c: Likewise. * generated/product_i16.c: Likewise. * generated/product_i1.c: Likewise. * generated/product_i2.c: Likewise. * generated/product_i4.c: Likewise. * generated/product_i8.c: Likewise. * generated/product_r10.c: Likewise. * generated/product_r16.c: Likewise. * generated/product_r4.c: Likewise. * generated/product_r8.c: Likewise. * generated/sum_c10.c: Likewise. * generated/sum_c16.c: Likewise. * generated/sum_c4.c: Likewise. * generated/sum_c8.c: Likewise. * generated/sum_i16.c: Likewise. * generated/sum_i1.c: Likewise. * generated/sum_i2.c: Likewise. * generated/sum_i4.c: Likewise. * generated/sum_i8.c: Likewise. * generated/sum_r10.c: Likewise. * generated/sum_r16.c: Likewise. * generated/sum_r4.c: Likewise. * generated/sum_r8.c: Likewise. * gfortran.dg/maxlocval_2.f90: New test. * gfortran.dg/maxlocval_3.f90: New test. * gfortran.dg/maxlocval_4.f90: New test. * gfortran.dg/minlocval_1.f90: New test. * gfortran.dg/minlocval_2.f90: New test. * gfortran.dg/minlocval_3.f90: New test. * gfortran.dg/minlocval_4.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150041 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 270835556ba..c625bc4bf60 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2755,7 +2755,7 @@ gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody) /* Generates the actual loop code for a scalarization loop. */ -static void +void gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, stmtblock_t * pbody) { @@ -2822,7 +2822,8 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, loopbody = gfc_finish_block (pbody); /* Initialize the loopvar. */ - gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]); + if (loop->loopvar[n] != loop->from[n]) + gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]); exit_label = gfc_build_label_decl (NULL_TREE); -- 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-array.c | 114 +++++++++++++++++++++++----------------------- 1 file changed, 57 insertions(+), 57 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c625bc4bf60..529a6b10495 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1533,7 +1533,7 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len) } } - *len = ts->cl->backend_decl; + *len = ts->u.cl->backend_decl; } @@ -1549,12 +1549,12 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) if (*len && INTEGER_CST_P (*len)) return; - if (!e->ref && e->ts.cl && e->ts.cl->length - && e->ts.cl->length->expr_type == EXPR_CONSTANT) + if (!e->ref && e->ts.u.cl && e->ts.u.cl->length + && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) { /* This is easy. */ - gfc_conv_const_charlen (e->ts.cl); - *len = e->ts.cl->backend_decl; + gfc_conv_const_charlen (e->ts.u.cl); + *len = e->ts.u.cl->backend_decl; } else { @@ -1575,7 +1575,7 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) gfc_add_block_to_block (block, &se.pre); gfc_add_block_to_block (block, &se.post); - e->ts.cl->backend_decl = *len; + e->ts.u.cl->backend_decl = *len; } } @@ -1825,8 +1825,8 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no typespec was given for the array constructor. */ - typespec_chararray_ctor = (ss->expr->ts.cl - && ss->expr->ts.cl->length_from_typespec); + typespec_chararray_ctor = (ss->expr->ts.u.cl + && ss->expr->ts.u.cl->length_from_typespec); if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor) @@ -1845,14 +1845,14 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) /* get_array_ctor_strlen walks the elements of the constructor, if a typespec was given, we already know the string length and want the one specified there. */ - if (typespec_chararray_ctor && ss->expr->ts.cl->length - && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT) + if (typespec_chararray_ctor && ss->expr->ts.u.cl->length + && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) { gfc_se length_se; const_string = false; gfc_init_se (&length_se, NULL); - gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length, + gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length, gfc_charlen_type_node); ss->string_length = length_se.expr; gfc_add_block_to_block (&loop->pre, &length_se.pre); @@ -1866,7 +1866,7 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) and not end up here. */ gcc_assert (ss->string_length); - ss->expr->ts.cl->backend_decl = ss->string_length; + ss->expr->ts.u.cl->backend_decl = ss->string_length; type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length); if (const_string) @@ -2096,11 +2096,11 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, case GFC_SS_CONSTRUCTOR: if (ss->expr->ts.type == BT_CHARACTER && ss->string_length == NULL - && ss->expr->ts.cl - && ss->expr->ts.cl->length) + && ss->expr->ts.u.cl + && ss->expr->ts.u.cl->length) { gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, ss->expr->ts.cl->length, + gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length, gfc_charlen_type_node); ss->string_length = se.expr; gfc_add_block_to_block (&loop->pre, &se.pre); @@ -4002,9 +4002,9 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset); if (expr->ts.type == BT_DERIVED - && expr->ts.derived->attr.alloc_comp) + && expr->ts.u.derived->attr.alloc_comp) { - tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr, + tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr, ref->u.ar.as->rank); gfc_add_expr_to_block (&se->pre, tmp); } @@ -4290,9 +4290,9 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) /* Evaluate character string length. */ if (sym->ts.type == BT_CHARACTER - && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl)) + && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &block); gfc_trans_vla_type_sizes (sym, &block); @@ -4315,8 +4315,8 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) gcc_assert (!sym->module); if (sym->ts.type == BT_CHARACTER - && !INTEGER_CST_P (sym->ts.cl->backend_decl)) - gfc_conv_string_length (sym->ts.cl, NULL, &block); + && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) + gfc_conv_string_length (sym->ts.u.cl, NULL, &block); size = gfc_trans_array_bounds (type, sym, &offset, &block); @@ -4381,8 +4381,8 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) gfc_start_block (&block); if (sym->ts.type == BT_CHARACTER - && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.cl, NULL, &block); + && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) + gfc_conv_string_length (sym->ts.u.cl, NULL, &block); /* Evaluate the bounds of the array. */ gfc_trans_array_bounds (type, sym, &offset, &block); @@ -4474,8 +4474,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) gfc_start_block (&block); if (sym->ts.type == BT_CHARACTER - && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.cl, NULL, &block); + && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) + gfc_conv_string_length (sym->ts.u.cl, NULL, &block); checkparm = (sym->as->type == AS_EXPLICIT && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); @@ -4867,11 +4867,11 @@ get_array_charlen (gfc_expr *expr, gfc_se *se) gfc_actual_arglist *arg; gfc_se tse; - if (expr->ts.cl->length - && gfc_is_constant_expr (expr->ts.cl->length)) + if (expr->ts.u.cl->length + && gfc_is_constant_expr (expr->ts.u.cl->length)) { - if (!expr->ts.cl->backend_decl) - gfc_conv_string_length (expr->ts.cl, expr, &se->pre); + if (!expr->ts.u.cl->backend_decl) + gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); return; } @@ -4880,11 +4880,11 @@ get_array_charlen (gfc_expr *expr, gfc_se *se) case EXPR_OP: get_array_charlen (expr->value.op.op1, se); - /* For parentheses the expression ts.cl is identical. */ + /* For parentheses the expression ts.u.cl is identical. */ if (expr->value.op.op == INTRINSIC_PARENTHESES) return; - expr->ts.cl->backend_decl = + expr->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node, "sln"); if (expr->value.op.op2) @@ -4895,21 +4895,21 @@ get_array_charlen (gfc_expr *expr, gfc_se *se) /* Add the string lengths and assign them to the expression string length backend declaration. */ - gfc_add_modify (&se->pre, expr->ts.cl->backend_decl, + gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, fold_build2 (PLUS_EXPR, gfc_charlen_type_node, - expr->value.op.op1->ts.cl->backend_decl, - expr->value.op.op2->ts.cl->backend_decl)); + expr->value.op.op1->ts.u.cl->backend_decl, + expr->value.op.op2->ts.u.cl->backend_decl)); } else - gfc_add_modify (&se->pre, expr->ts.cl->backend_decl, - expr->value.op.op1->ts.cl->backend_decl); + gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, + expr->value.op.op1->ts.u.cl->backend_decl); break; case EXPR_FUNCTION: if (expr->value.function.esym == NULL - || expr->ts.cl->length->expr_type == EXPR_CONSTANT) + || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) { - gfc_conv_string_length (expr->ts.cl, expr, &se->pre); + gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); break; } @@ -4932,19 +4932,19 @@ get_array_charlen (gfc_expr *expr, gfc_se *se) gfc_init_se (&tse, NULL); /* Build the expression for the character length and convert it. */ - gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length); + gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length); gfc_add_block_to_block (&se->pre, &tse.pre); gfc_add_block_to_block (&se->post, &tse.post); tse.expr = fold_convert (gfc_charlen_type_node, tse.expr); tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr, build_int_cst (gfc_charlen_type_node, 0)); - expr->ts.cl->backend_decl = tse.expr; + expr->ts.u.cl->backend_decl = tse.expr; gfc_free_interface_mapping (&mapping); break; default: - gfc_conv_string_length (expr->ts.cl, expr, &se->pre); + gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); break; } } @@ -5085,7 +5085,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) /* Elemental function. */ need_tmp = 1; if (expr->ts.type == BT_CHARACTER - && expr->ts.cl->length->expr_type != EXPR_CONSTANT) + && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) get_array_charlen (expr, se); info = NULL; @@ -5147,13 +5147,13 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) loop.temp_ss->next = gfc_ss_terminator; if (expr->ts.type == BT_CHARACTER - && !expr->ts.cl->backend_decl) + && !expr->ts.u.cl->backend_decl) get_array_charlen (expr, se); loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts); 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; @@ -5469,7 +5469,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER) { get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp); - expr->ts.cl->backend_decl = tmp; + expr->ts.u.cl->backend_decl = tmp; se->string_length = tmp; } @@ -5486,7 +5486,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, tmp = gfc_get_symbol_decl (sym); if (sym->ts.type == BT_CHARACTER) - se->string_length = sym->ts.cl->backend_decl; + se->string_length = sym->ts.u.cl->backend_decl; if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE && !sym->attr.allocatable) { @@ -5543,12 +5543,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, /* Deallocate the allocatable components of structures that are not variable. */ if (expr->ts.type == BT_DERIVED - && expr->ts.derived->attr.alloc_comp + && expr->ts.u.derived->attr.alloc_comp && expr->expr_type != EXPR_VARIABLE) { tmp = build_fold_indirect_ref_loc (input_location, se->expr); - tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank); + tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank); gfc_add_expr_to_block (&se->post, tmp); } @@ -5854,7 +5854,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, for (c = der_type->components; c; c = c->next) { bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED) - && c->ts.derived->attr.alloc_comp; + && c->ts.u.derived->attr.alloc_comp; cdecl = c->backend_decl; ctype = TREE_TYPE (cdecl); @@ -5868,7 +5868,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); rank = c->as ? c->as->rank : 0; - tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE, + tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, rank, purpose); gfc_add_expr_to_block (&fnblock, tmp); } @@ -5896,7 +5896,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); rank = c->as ? c->as->rank : 0; - tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE, + tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, rank, purpose); gfc_add_expr_to_block (&fnblock, tmp); } @@ -5922,7 +5922,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, rank = c->as ? c->as->rank : 0; tmp = fold_convert (TREE_TYPE (dcmp), comp); gfc_add_modify (&fnblock, dcmp, tmp); - tmp = structure_alloc_comps (c->ts.derived, comp, dcmp, + tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, rank, purpose); gfc_add_expr_to_block (&fnblock, tmp); } @@ -5985,7 +5985,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) bool sym_has_alloc_comp; sym_has_alloc_comp = (sym->ts.type == BT_DERIVED) - && sym->ts.derived->attr.alloc_comp; + && sym->ts.u.derived->attr.alloc_comp; /* Make sure the frontend gets these right. */ if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp)) @@ -5999,9 +5999,9 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) || TREE_CODE (sym->backend_decl) == PARM_DECL); if (sym->ts.type == BT_CHARACTER - && !INTEGER_CST_P (sym->ts.cl->backend_decl)) + && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.cl, NULL, &fnblock); + gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock); gfc_trans_vla_type_sizes (sym, &fnblock); } @@ -6035,7 +6035,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) if (!sym->attr.save) { rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank); + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank); gfc_add_expr_to_block (&fnblock, tmp); if (sym->value) { @@ -6068,7 +6068,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) { int rank; rank = sym->as ? sym->as->rank : 0; - tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank); + tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank); gfc_add_expr_to_block (&fnblock, tmp); } -- 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-array.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 529a6b10495..31c59c6ee84 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -725,7 +725,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, /* Initialize the descriptor. */ type = gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1, - GFC_ARRAY_UNKNOWN); + GFC_ARRAY_UNKNOWN, true); desc = gfc_create_var (type, "atmp"); GFC_DECL_PACKED_ARRAY (desc) = 1; @@ -1715,7 +1715,7 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type) as.upper[i] = gfc_int_expr (tmp - 1); } - tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC); + tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); init = build_constructor_from_list (tmptype, nreverse (list)); @@ -5250,7 +5250,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) parmtype = gfc_get_element_type (TREE_TYPE (desc)); parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, loop.from, loop.to, 0, - GFC_ARRAY_UNKNOWN); + GFC_ARRAY_UNKNOWN, false); parm = gfc_create_var (parmtype, "parm"); } -- 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-array.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 31c59c6ee84..0c00d322ae7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5873,7 +5873,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_expr_to_block (&fnblock, tmp); } - if (c->attr.allocatable) + if (c->attr.allocatable && c->attr.dimension) { comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); @@ -5885,7 +5885,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, case NULLIFY_ALLOC_COMP: if (c->attr.pointer) continue; - else if (c->attr.allocatable) + else if (c->attr.allocatable && c->attr.dimension) { comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); @@ -6072,7 +6072,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) gfc_add_expr_to_block (&fnblock, tmp); } - if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result) + if (sym->attr.allocatable && sym->attr.dimension + && !sym->attr.save && !sym->attr.result) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl); gfc_add_expr_to_block (&fnblock, tmp); -- cgit v1.2.1 From 9619f2e31757f5ca1c8f0015d2911f3603e88674 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Thu, 1 Oct 2009 02:32:41 +0000 Subject: 2009-09-30 Dennis Wassel * gcc/fortran/trans-array.c (gfc_trans_array_bound_check): Improved bounds checking error messages. (gfc_conv_array_ref): Likewise. (gfc_conv_ss_startstride): Likewise. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152355 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 198 ++++++++++++++++++++++++++-------------------- 1 file changed, 112 insertions(+), 86 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0c00d322ae7..e16200010d1 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2296,7 +2296,7 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, locus * where, bool check_upper) { tree fault; - tree tmp; + tree tmp_lo, tmp_up; char *msg; const char * name = NULL; @@ -2333,34 +2333,46 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, name = "unnamed constant"; } - /* Check lower bound. */ - tmp = gfc_conv_array_lbound (descriptor, n); - fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp); - if (name) - asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded" - "(%%ld < %%ld)", gfc_msg_fault, name, n+1); - else - asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)", - gfc_msg_fault, n+1); - gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, - fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp)); - gfc_free (msg); - - /* Check upper bound. */ + /* If upper bound is present, include both bounds in the error message. */ if (check_upper) { - tmp = gfc_conv_array_ubound (descriptor, n); - fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp); + tmp_lo = gfc_conv_array_lbound (descriptor, n); + tmp_up = gfc_conv_array_ubound (descriptor, n); + if (name) - asprintf (&msg, "%s for array '%s', upper bound of dimension %d " - " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1); + asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " + "outside of expected range (%%ld:%%ld)", n+1, name); else - asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)", - gfc_msg_fault, n+1); + asprintf (&msg, "Index '%%ld' of dimension %d " + "outside of expected range (%%ld:%%ld)", n+1); + + fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo); gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp)); + fold_convert (long_integer_type_node, tmp_lo), + fold_convert (long_integer_type_node, tmp_up)); + fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up); + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, + fold_convert (long_integer_type_node, index), + fold_convert (long_integer_type_node, tmp_lo), + fold_convert (long_integer_type_node, tmp_up)); + gfc_free (msg); + } + else + { + tmp_lo = gfc_conv_array_lbound (descriptor, n); + + if (name) + asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " + "below lower bound of %%ld", n+1, name); + else + asprintf (&msg, "Index '%%ld' of dimension %d " + "below lower bound of %%ld", n+1); + + fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo); + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, + fold_convert (long_integer_type_node, index), + fold_convert (long_integer_type_node, tmp_lo)); gfc_free (msg); } @@ -2561,9 +2573,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, cond = fold_build2 (LT_EXPR, boolean_type_node, indexse.expr, tmp); - asprintf (&msg, "%s for array '%s', " - "lower bound of dimension %d exceeded (%%ld < %%ld)", - gfc_msg_fault, sym->name, n+1); + asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " + "below lower bound of %%ld", n+1, sym->name); gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, fold_convert (long_integer_type_node, indexse.expr), @@ -2587,9 +2598,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, cond = fold_build2 (GT_EXPR, boolean_type_node, indexse.expr, tmp); - asprintf (&msg, "%s for array '%s', " - "upper bound of dimension %d exceeded (%%ld > %%ld)", - gfc_msg_fault, sym->name, n+1); + asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " + "above upper bound of %%ld", n+1, sym->name); gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, fold_convert (long_integer_type_node, indexse.expr), @@ -3166,7 +3176,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) tree lbound, ubound; tree end; tree size[GFC_MAX_DIMENSIONS]; - tree stride_pos, stride_neg, non_zerosized, tmp2; + tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3; gfc_ss_info *info; char *msg; int dim; @@ -3246,77 +3256,95 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) stride_pos, stride_neg); /* Check the start of the range against the lower and upper - bounds of the array, if the range is not empty. */ - tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n], - lbound); - tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - non_zerosized, tmp); - asprintf (&msg, "%s, lower bound of dimension %d of array '%s'" - " exceeded (%%ld < %%ld)", gfc_msg_fault, - info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (true, false, tmp, &inner, - &ss->expr->where, msg, - fold_convert (long_integer_type_node, - info->start[n]), - fold_convert (long_integer_type_node, - lbound)); - gfc_free (msg); - + bounds of the array, if the range is not empty. + If upper bound is present, include both bounds in the + error message. */ if (check_upper) { - tmp = fold_build2 (GT_EXPR, boolean_type_node, - info->start[n], ubound); + tmp = fold_build2 (LT_EXPR, boolean_type_node, + info->start[n], lbound); tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp); - asprintf (&msg, "%s, upper bound of dimension %d of array " - "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault, + tmp2 = fold_build2 (GT_EXPR, boolean_type_node, + info->start[n], ubound); + tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, + non_zerosized, tmp2); + asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " + "outside of expected range (%%ld:%%ld)", info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (true, false, tmp, &inner, - &ss->expr->where, msg, - fold_convert (long_integer_type_node, info->start[n]), - fold_convert (long_integer_type_node, ubound)); + gfc_trans_runtime_check (true, false, tmp, &inner, + &ss->expr->where, msg, + fold_convert (long_integer_type_node, info->start[n]), + fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, ubound)); + gfc_trans_runtime_check (true, false, tmp2, &inner, + &ss->expr->where, msg, + fold_convert (long_integer_type_node, info->start[n]), + fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, ubound)); gfc_free (msg); } - + else + { + tmp = fold_build2 (LT_EXPR, boolean_type_node, + info->start[n], lbound); + tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, + non_zerosized, tmp); + asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " + "below lower bound of %%ld", + info->dim[n]+1, ss->expr->symtree->name); + gfc_trans_runtime_check (true, false, tmp, &inner, + &ss->expr->where, msg, + fold_convert (long_integer_type_node, info->start[n]), + fold_convert (long_integer_type_node, lbound)); + gfc_free (msg); + } + /* Compute the last element of the range, which is not necessarily "end" (think 0:5:3, which doesn't contain 5) and check it against both lower and upper bounds. */ - tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, + + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, info->start[n]); - tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2, + tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp, info->stride[n]); - tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, - tmp2); - - tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound); - tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - non_zerosized, tmp); - asprintf (&msg, "%s, lower bound of dimension %d of array '%s'" - " exceeded (%%ld < %%ld)", gfc_msg_fault, - info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (true, false, tmp, &inner, - &ss->expr->where, msg, - fold_convert (long_integer_type_node, - tmp2), - fold_convert (long_integer_type_node, - lbound)); - gfc_free (msg); - + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, + tmp); + tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound); + tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, + non_zerosized, tmp2); if (check_upper) { - tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound); - tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - non_zerosized, tmp); - asprintf (&msg, "%s, upper bound of dimension %d of array " - "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault, + tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound); + tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, + non_zerosized, tmp3); + asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " + "outside of expected range (%%ld:%%ld)", info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (true, false, tmp, &inner, - &ss->expr->where, msg, - fold_convert (long_integer_type_node, tmp2), - fold_convert (long_integer_type_node, ubound)); + gfc_trans_runtime_check (true, false, tmp2, &inner, + &ss->expr->where, msg, + fold_convert (long_integer_type_node, tmp), + fold_convert (long_integer_type_node, ubound), + fold_convert (long_integer_type_node, lbound)); + gfc_trans_runtime_check (true, false, tmp3, &inner, + &ss->expr->where, msg, + fold_convert (long_integer_type_node, tmp), + fold_convert (long_integer_type_node, ubound), + fold_convert (long_integer_type_node, lbound)); gfc_free (msg); } - + else + { + asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " + "below lower bound of %%ld", + info->dim[n]+1, ss->expr->symtree->name); + gfc_trans_runtime_check (true, false, tmp2, &inner, + &ss->expr->where, msg, + fold_convert (long_integer_type_node, tmp), + fold_convert (long_integer_type_node, lbound)); + gfc_free (msg); + } + /* Check the section sizes match. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, info->start[n]); @@ -3330,8 +3358,6 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) others against this. */ if (size[n]) { - tree tmp3; - tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]); asprintf (&msg, "%s, size mismatch for dimension %d " "of array '%s' (%%ld/%%ld)", gfc_msg_bounds, -- cgit v1.2.1 From 0a96a7ccecc2a2e9bf373254760deaf74d43cadf Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 19 Oct 2009 19:21:18 +0000 Subject: 2009-10-19 Janus Weil PR fortran/41586 * parse.c (parse_derived): Correctly set 'alloc_comp' and 'pointer_comp' for CLASS variables. * trans-array.c (structure_alloc_comps): Handle deallocation and nullification of allocatable scalar components. * trans-decl.c (gfc_get_symbol_decl): Remember allocatable scalars for automatic deallocation. (gfc_trans_deferred_vars): Automatically deallocate allocatable scalars. 2009-10-19 Janus Weil PR fortran/41586 * gfortran.dg/auto_dealloc_1.f90: New test case. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152988 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 51 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index e16200010d1..4e94373133a 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5906,6 +5906,36 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tmp = gfc_trans_dealloc_allocated (comp); gfc_add_expr_to_block (&fnblock, tmp); } + else if (c->attr.allocatable) + { + /* Allocatable scalar components. */ + comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); + + tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL); + gfc_add_expr_to_block (&fnblock, tmp); + + tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp, + build_int_cst (TREE_TYPE (comp), 0)); + gfc_add_expr_to_block (&fnblock, tmp); + } + else if (c->ts.type == BT_CLASS + && c->ts.u.derived->components->attr.allocatable) + { + /* Allocatable scalar CLASS components. */ + comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); + + /* Add reference to '$data' component. */ + tmp = c->ts.u.derived->components->backend_decl; + comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), + comp, tmp, NULL_TREE); + + tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL); + gfc_add_expr_to_block (&fnblock, tmp); + + tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp, + build_int_cst (TREE_TYPE (comp), 0)); + gfc_add_expr_to_block (&fnblock, tmp); + } break; case NULLIFY_ALLOC_COMP: @@ -5917,6 +5947,27 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, decl, cdecl, NULL_TREE); gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); } + else if (c->attr.allocatable) + { + /* Allocatable scalar components. */ + comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); + tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp, + build_int_cst (TREE_TYPE (comp), 0)); + gfc_add_expr_to_block (&fnblock, tmp); + } + else if (c->ts.type == BT_CLASS + && c->ts.u.derived->components->attr.allocatable) + { + /* Allocatable scalar CLASS components. */ + comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); + /* Add reference to '$data' component. */ + tmp = c->ts.u.derived->components->backend_decl; + comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), + comp, tmp, NULL_TREE); + tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp, + build_int_cst (TREE_TYPE (comp), 0)); + gfc_add_expr_to_block (&fnblock, tmp); + } else if (cmp_has_alloc_comps) { comp = fold_build3 (COMPONENT_REF, ctype, -- cgit v1.2.1 From 74cb78739e6df71e061981de5312503659952164 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Thu, 26 Nov 2009 19:05:37 +0000 Subject: 2009-11-26 Jerry DeLisle PR fortran/41278 * trans-array.c (gfc_conv_array_transpose): Delete unnecessary assert. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154680 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 1 - 1 file changed, 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 4e94373133a..e22fcf7e426 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -850,7 +850,6 @@ gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr) src_info = &src_ss->data.info; dest_info = &dest_ss->data.info; gcc_assert (dest_info->dimen == 2); - gcc_assert (src_info->dimen == 2); /* Get a descriptor for EXPR. */ gfc_init_se (&src_se, NULL); -- 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-array.c | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index e22fcf7e426..6486bb60ec6 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -837,7 +837,7 @@ gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr) { tree dest, src, dest_index, src_index; gfc_loopinfo *loop; - gfc_ss_info *dest_info, *src_info; + gfc_ss_info *dest_info; gfc_ss *dest_ss, *src_ss; gfc_se src_se; int n; @@ -847,7 +847,6 @@ gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr) src_ss = gfc_walk_expr (expr); dest_ss = se->ss; - src_info = &src_ss->data.info; dest_info = &dest_ss->data.info; gcc_assert (dest_info->dimen == 2); @@ -3458,13 +3457,9 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, gfc_ss *ss; gfc_ref *lref; gfc_ref *rref; - gfc_ref *aref; int nDepend = 0; - int temp_dim = 0; loop->temp_ss = NULL; - aref = dest->data.info.ref; - temp_dim = 0; for (ss = rss; ss != gfc_ss_terminator; ss = ss->next) { @@ -3513,7 +3508,6 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, if (depends[n]) loop->order[dim++] = n; } - temp_dim = dim; for (n = 0; n < loop->dimen; n++) { if (! depends[n]) @@ -3556,12 +3550,10 @@ void gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) { int n; - int dim; gfc_ss_info *info; gfc_ss_info *specinfo; gfc_ss *ss; tree tmp; - tree len; gfc_ss *loopspec[GFC_MAX_DIMENSIONS]; bool dynamic[GFC_MAX_DIMENSIONS]; gfc_constructor *c; @@ -3742,7 +3734,6 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) loop->temp_ss->string_length); tmp = loop->temp_ss->data.temp.type; - len = loop->temp_ss->string_length; n = loop->temp_ss->data.temp.dimen; memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info)); loop->temp_ss->type = GFC_SS_SECTION; @@ -3774,8 +3765,6 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) for (n = 0; n < info->dimen; n++) { - dim = info->dim[n]; - /* If we are specifying the range the delta is already set. */ if (loopspec[n] != ss) { @@ -6179,7 +6168,6 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) gfc_ref *ref; gfc_array_ref *ar; gfc_ss *newss; - gfc_ss *head; int n; for (ref = expr->ref; ref; ref = ref->next) @@ -6252,8 +6240,6 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) newss->data.info.dimen = 0; newss->data.info.ref = ref; - head = newss; - /* We add SS chains for all the subscripts in the section. */ for (n = 0; n < ar->dimen; n++) { -- cgit v1.2.1 From c315461d1a22ed500bc4d1f2897dddcb77a9e011 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Sat, 9 Jan 2010 17:47:04 +0000 Subject: 2010-01-09 Jerry DeLisle PR fortran/20923 PR fortran/32489 * trans-array.c (gfc_conv_array_initializer): Change call to gfc_error_now to call to gfc_fatal_error. * array.c (count_elements): Whitespace. (extract_element): Whitespace. (is_constant_element): Changed name from constant_element. (gfc_constant_ac): Only use expand_construuctor for expression types of EXPR_ARRAY. If expression type is EXPR_CONSTANT, no need to call gfc_is_constant_expr. * expr.c (gfc_reduce_init_expr): Adjust conditionals and delete error message. * resolve.c (gfc_is_expandable_expr): New function that determiners if array expressions should have their constructors expanded. (gfc_resolve_expr): Use new function to determine whether or not to call gfc_expand_constructor. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155769 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6486bb60ec6..063b26297a7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4109,11 +4109,11 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) { /* Problems occur when we get something like integer :: a(lots) = (/(i, i=1, lots)/) */ - gfc_error_now ("The number of elements in the array constructor " - "at %L requires an increase of the allowed %d " - "upper limit. See -fmax-array-constructor " - "option", &expr->where, - gfc_option.flag_max_array_constructor); + gfc_fatal_error ("The number of elements in the array constructor " + "at %L requires an increase of the allowed %d " + "upper limit. See -fmax-array-constructor " + "option", &expr->where, + gfc_option.flag_max_array_constructor); return NULL_TREE; } if (mpz_cmp_si (c->n.offset, 0) != 0) -- 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-array.c | 127 ++++++++++++++++++++++++++++++++++++---------- 1 file changed, 99 insertions(+), 28 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 063b26297a7..d512da4db6b 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5711,10 +5711,12 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank) } -/* Allocate dest to the same size as src, and copy src -> dest. */ +/* Allocate dest to the same size as src, and copy src -> dest. + If no_malloc is set, only the copy is done. */ -tree -gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank) +static tree +duplicate_allocatable(tree dest, tree src, tree type, int rank, + bool no_malloc) { tree tmp; tree size; @@ -5723,35 +5725,66 @@ gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank) tree null_data; stmtblock_t block; - /* If the source is null, set the destination to null. */ + /* If the source is null, set the destination to null. Then, + allocate memory to the destination. */ gfc_init_block (&block); - gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); - null_data = gfc_finish_block (&block); - gfc_init_block (&block); + if (rank == 0) + { + tmp = null_pointer_node; + tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp); + gfc_add_expr_to_block (&block, tmp); + null_data = gfc_finish_block (&block); + + gfc_init_block (&block); + size = TYPE_SIZE_UNIT (type); + if (!no_malloc) + { + tmp = gfc_call_malloc (&block, type, size); + tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest, + fold_convert (type, tmp)); + gfc_add_expr_to_block (&block, tmp); + } + + tmp = built_in_decls[BUILT_IN_MEMCPY]; + tmp = build_call_expr_loc (input_location, tmp, 3, + dest, src, size); + } + else + { + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + null_data = gfc_finish_block (&block); + + gfc_init_block (&block); + nelems = get_full_array_size (&block, src, rank); + tmp = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp); + if (!no_malloc) + { + tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src)); + tmp = gfc_call_malloc (&block, tmp, size); + gfc_conv_descriptor_data_set (&block, dest, tmp); + } + + /* We know the temporary and the value will be the same length, + so can use memcpy. */ + tmp = built_in_decls[BUILT_IN_MEMCPY]; + tmp = build_call_expr_loc (input_location, + tmp, 3, gfc_conv_descriptor_data_get (dest), + gfc_conv_descriptor_data_get (src), size); + } - nelems = get_full_array_size (&block, src, rank); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, - fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type)))); - - /* Allocate memory to the destination. */ - tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)), - size); - gfc_conv_descriptor_data_set (&block, dest, tmp); - - /* We know the temporary and the value will be the same length, - so can use memcpy. */ - tmp = built_in_decls[BUILT_IN_MEMCPY]; - tmp = build_call_expr_loc (input_location, - tmp, 3, gfc_conv_descriptor_data_get (dest), - gfc_conv_descriptor_data_get (src), size); gfc_add_expr_to_block (&block, tmp); tmp = gfc_finish_block (&block); /* Null the destination if the source is null; otherwise do the allocate and copy. */ - null_cond = gfc_conv_descriptor_data_get (src); + if (rank == 0) + null_cond = src; + else + null_cond = gfc_conv_descriptor_data_get (src); + null_cond = convert (pvoid_type_node, null_cond); null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond, null_pointer_node); @@ -5759,11 +5792,30 @@ gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank) } +/* Allocate dest to the same size as src, and copy data src -> dest. */ + +tree +gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank) +{ + return duplicate_allocatable(dest, src, type, rank, false); +} + + +/* Copy data src -> dest. */ + +tree +gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) +{ + return duplicate_allocatable(dest, src, type, rank, true); +} + + /* Recursively traverse an object of derived type, generating code to deallocate, nullify or copy allocatable components. This is the work horse function for the functions named in this enum. */ -enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP}; +enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, + COPY_ONLY_ALLOC_COMP}; static tree structure_alloc_comps (gfc_symbol * der_type, tree decl, @@ -5786,7 +5838,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_init_block (&fnblock); - if (POINTER_TYPE_P (TREE_TYPE (decl))) + if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0) decl = build_fold_indirect_ref_loc (input_location, decl); @@ -5841,6 +5893,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, dref = gfc_build_array_ref (tmp, index, NULL); tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose); } + else if (purpose == COPY_ONLY_ALLOC_COMP) + { + tmp = build_fold_indirect_ref_loc (input_location, + gfc_conv_array_data (dest)); + dref = gfc_build_array_ref (tmp, index, NULL); + tmp = structure_alloc_comps (der_type, vref, dref, rank, + COPY_ALLOC_COMP); + } else tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose); @@ -5978,7 +6038,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (c->attr.allocatable && !cmp_has_alloc_comps) { - tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank); + rank = c->as ? c->as->rank : 0; + tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank); gfc_add_expr_to_block (&fnblock, tmp); } @@ -6025,7 +6086,7 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank) /* Recursively traverse an object of derived type, generating code to - copy its allocatable components. */ + copy it and its allocatable components. */ tree gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) @@ -6034,6 +6095,16 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) } +/* Recursively traverse an object of derived type, generating code to + copy only its allocatable components. */ + +tree +gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) +{ + return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP); +} + + /* NULLIFY an allocatable/pointer array on function entry, free it on exit. Do likewise, recursively if necessary, with the allocatable components of derived types. */ -- cgit v1.2.1 From d3d55916c91efbc4113970938c4d8480de5fe72f Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 13 Feb 2010 12:42:39 +0000 Subject: 2010-02-13 Paul Thomas PR fortran/41113 PR fortran/41117 * trans-array.c (gfc_conv_array_parameter): Use gfc_full_array_ref_p to detect full and contiguous variable arrays. Full array components and contiguous arrays do not need internal_pack and internal_unpack. 2010-02-13 Paul Thomas PR fortran/41113 PR fortran/41117 * gfortran.dg/internal_pack_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156749 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 41 ++++++++++++++++++++++++++++++++++++----- 1 file changed, 36 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index d512da4db6b..ae39aed1c58 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5468,17 +5468,27 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, tree tmp = NULL_TREE; tree stmt; tree parent = DECL_CONTEXT (current_function_decl); - bool full_array_var, this_array_result; + bool full_array_var; + bool this_array_result; + bool contiguous; gfc_symbol *sym; stmtblock_t block; + gfc_ref *ref; + + for (ref = expr->ref; ref; ref = ref->next) + if (ref->next == NULL) + break; + + full_array_var = false; + contiguous = false; + + if (expr->expr_type == EXPR_VARIABLE && ref) + full_array_var = gfc_full_array_ref_p (ref, &contiguous); - full_array_var = (expr->expr_type == EXPR_VARIABLE - && expr->ref->type == REF_ARRAY - && expr->ref->u.ar.type == AR_FULL); sym = full_array_var ? expr->symtree->n.sym : NULL; /* The symbol should have an array specification. */ - gcc_assert (!sym || sym->as); + gcc_assert (!sym || sym->as || ref->u.ar.as); if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER) { @@ -5501,6 +5511,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, if (sym->ts.type == BT_CHARACTER) se->string_length = sym->ts.u.cl->backend_decl; + + if (sym->ts.type == BT_DERIVED && !sym->as) + { + gfc_conv_expr_descriptor (se, expr, ss); + se->expr = gfc_conv_array_data (se->expr); + return; + } + if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE && !sym->attr.allocatable) { @@ -5514,6 +5532,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, array_parameter_size (tmp, expr, size); return; } + if (sym->attr.allocatable) { if (sym->attr.dummy || sym->attr.result) @@ -5528,6 +5547,18 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, } } + if (contiguous && g77 && !this_array_result + && !expr->symtree->n.sym->attr.dummy) + { + gfc_conv_expr_descriptor (se, expr, ss); + if (expr->ts.type == BT_CHARACTER) + se->string_length = expr->ts.u.cl->backend_decl; + if (size) + array_parameter_size (se->expr, expr, size); + se->expr = gfc_conv_array_data (se->expr); + return; + } + if (this_array_result) { /* Result of the enclosing function. */ -- 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-array.c | 38 ++++++++++++++++++++++++++++++++------ 1 file changed, 32 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ae39aed1c58..2ea978d0ece 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5459,7 +5459,7 @@ array_parameter_size (tree desc, gfc_expr *expr, tree *size) /* TODO: Optimize passing g77 arrays. */ void -gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, +gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, const gfc_symbol *fsym, const char *proc_name, tree *size) { @@ -5471,6 +5471,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, bool full_array_var; bool this_array_result; bool contiguous; + bool no_pack; gfc_symbol *sym; stmtblock_t block; gfc_ref *ref; @@ -5519,8 +5520,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, return; } - if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE - && !sym->attr.allocatable) + if (!sym->attr.pointer + && sym->as + && sym->as->type != AS_ASSUMED_SHAPE + && !sym->attr.allocatable) { /* Some variables are declared directly, others are declared as pointers and allocated on the heap. */ @@ -5547,8 +5550,32 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, } } - if (contiguous && g77 && !this_array_result - && !expr->symtree->n.sym->attr.dummy) + /* There is no need to pack and unpack the array, if it is an array + constructor or contiguous and not deferred or assumed shape. */ + no_pack = ((sym && sym->as + && !sym->attr.pointer + && sym->as->type != AS_DEFERRED + && sym->as->type != AS_ASSUMED_SHAPE) + || + (ref && ref->u.ar.as + && ref->u.ar.as->type != AS_DEFERRED + && ref->u.ar.as->type != AS_ASSUMED_SHAPE)); + + no_pack = g77 && !this_array_result + && (expr->expr_type == EXPR_ARRAY || (contiguous && no_pack)); + + if (no_pack) + { + gfc_conv_expr_descriptor (se, expr, ss); + if (expr->ts.type == BT_CHARACTER) + se->string_length = expr->ts.u.cl->backend_decl; + if (size) + array_parameter_size (se->expr, expr, size); + se->expr = gfc_conv_array_data (se->expr); + return; + } + + if (expr->expr_type == EXPR_ARRAY && g77) { gfc_conv_expr_descriptor (se, expr, ss); if (expr->ts.type == BT_CHARACTER) @@ -5601,7 +5628,6 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, { desc = se->expr; /* Repack the array. */ - if (gfc_option.warn_array_temp) { if (fsym) -- cgit v1.2.1 From 34de9f8b3f212ffcb65ba1f4bb8f697c6ecf336a Mon Sep 17 00:00:00 2001 From: pault Date: Tue, 2 Mar 2010 11:58:02 +0000 Subject: 2010-03-02 Paul Thomas PR fortran/43180 * trans-array.c (gfc_conv_array_parameter): A full array of derived type need not be restricted to a symbol without an array spec to use the call to gfc_conv_expr_descriptor. PR fortran/43173 * trans-array.c (gfc_conv_array_parameter): Contiguous refs to allocatable arrays do not need temporaries. 2010-03-02 Paul Thomas PR fortran/43180 * gfortran.dg/internal_pack_10.f90: New test. PR fortran/43173 * gfortran.dg/internal_pack_11.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157163 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 2ea978d0ece..c8728899c6d 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5472,6 +5472,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, bool this_array_result; bool contiguous; bool no_pack; + bool array_constructor; + bool good_allocatable; gfc_symbol *sym; stmtblock_t block; gfc_ref *ref; @@ -5513,7 +5515,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, if (sym->ts.type == BT_CHARACTER) se->string_length = sym->ts.u.cl->backend_decl; - if (sym->ts.type == BT_DERIVED && !sym->as) + if (sym->ts.type == BT_DERIVED) { gfc_conv_expr_descriptor (se, expr, ss); se->expr = gfc_conv_array_data (se->expr); @@ -5550,8 +5552,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, } } - /* There is no need to pack and unpack the array, if it is an array - constructor or contiguous and not deferred or assumed shape. */ + /* There is no need to pack and unpack the array, if it is contiguous + and not deferred or assumed shape. */ no_pack = ((sym && sym->as && !sym->attr.pointer && sym->as->type != AS_DEFERRED @@ -5561,21 +5563,17 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, && ref->u.ar.as->type != AS_DEFERRED && ref->u.ar.as->type != AS_ASSUMED_SHAPE)); - no_pack = g77 && !this_array_result - && (expr->expr_type == EXPR_ARRAY || (contiguous && no_pack)); + no_pack = g77 && !this_array_result && contiguous && no_pack; - if (no_pack) - { - gfc_conv_expr_descriptor (se, expr, ss); - if (expr->ts.type == BT_CHARACTER) - se->string_length = expr->ts.u.cl->backend_decl; - if (size) - array_parameter_size (se->expr, expr, size); - se->expr = gfc_conv_array_data (se->expr); - return; - } + /* Array constructors are always contiguous and do not need packing. */ + array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY; + + /* Same is true of contiguous sections from allocatable variables. */ + good_allocatable = (g77 && !this_array_result && contiguous + && expr->symtree + && expr->symtree->n.sym->attr.allocatable); - if (expr->expr_type == EXPR_ARRAY && g77) + if (no_pack || array_constructor || good_allocatable) { gfc_conv_expr_descriptor (se, expr, ss); if (expr->ts.type == BT_CHARACTER) -- cgit v1.2.1 From 1fd5778e5078350eb7d1b9f67defadea8606d56a Mon Sep 17 00:00:00 2001 From: pault Date: Wed, 3 Mar 2010 17:49:53 +0000 Subject: 2010-03-03 Paul Thomas PR fortran/43243 * trans-array.c (gfc_conv_array_parameter): Contiguous refs to allocatable ultimate components do not need temporaries, whilst ultimate pointer components do. 2010-03-03 Paul Thomas PR fortran/43243 * gfortran.dg/internal_pack_12.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157199 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 34 ++++++++++++++++++++++++++-------- 1 file changed, 26 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c8728899c6d..8eea3aca716 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5474,18 +5474,30 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, bool no_pack; bool array_constructor; bool good_allocatable; + bool ultimate_ptr_comp; + bool ultimate_alloc_comp; gfc_symbol *sym; stmtblock_t block; gfc_ref *ref; + ultimate_ptr_comp = false; + ultimate_alloc_comp = false; for (ref = expr->ref; ref; ref = ref->next) - if (ref->next == NULL) - break; + { + if (ref->next == NULL) + break; + + if (ref->type == REF_COMPONENT) + { + ultimate_ptr_comp = ref->u.c.component->attr.pointer; + ultimate_alloc_comp = ref->u.c.component->attr.allocatable; + } + } full_array_var = false; contiguous = false; - if (expr->expr_type == EXPR_VARIABLE && ref) + if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp) full_array_var = gfc_full_array_ref_p (ref, &contiguous); sym = full_array_var ? expr->symtree->n.sym : NULL; @@ -5552,6 +5564,9 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, } } + /* A convenient reduction in scope. */ + contiguous = g77 && !this_array_result && contiguous; + /* There is no need to pack and unpack the array, if it is contiguous and not deferred or assumed shape. */ no_pack = ((sym && sym->as @@ -5563,17 +5578,20 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, && ref->u.ar.as->type != AS_DEFERRED && ref->u.ar.as->type != AS_ASSUMED_SHAPE)); - no_pack = g77 && !this_array_result && contiguous && no_pack; + no_pack = contiguous && no_pack; /* Array constructors are always contiguous and do not need packing. */ array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY; /* Same is true of contiguous sections from allocatable variables. */ - good_allocatable = (g77 && !this_array_result && contiguous - && expr->symtree - && expr->symtree->n.sym->attr.allocatable); + good_allocatable = contiguous + && expr->symtree + && expr->symtree->n.sym->attr.allocatable; + + /* Or ultimate allocatable components. */ + ultimate_alloc_comp = contiguous && ultimate_alloc_comp; - if (no_pack || array_constructor || good_allocatable) + if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp) { gfc_conv_expr_descriptor (se, expr, ss); if (expr->ts.type == BT_CHARACTER) -- cgit v1.2.1 From 452695a8da676319b005b0fdfafc623139ea2f83 Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 17 Mar 2010 09:53:40 +0000 Subject: 2010-03-17 Tobias Burnus PR fortran/43331 * trans-array.c (gfc_conv_array_index_offset,gfc_conv_array_ref, gfc_conv_ss_startstride): Remove no-longer-needed cp_was_assumed check. * decl.c (gfc_match_derived_decl): Don't mark assumed-size Cray pointees as having explizit size. * expr.c (gfc_check_assign): Remove now unreachable Cray pointee check. * trans-types.c (gfc_is_nodesc_array): Add cp_was_assumed to * assert. (gfc_sym_type): Don't mark Cray pointees as restricted pointers. * resolve.c (resolve_symbol): Handle cp_was_assumed. * trans-decl.c (gfc_trans_deferred_vars): Ditto. (gfc_finish_var_decl): Don't mark Cray pointees as restricted pointers. 2010-03-17 Tobias Burnus PR fortran/43331 * gfortran.dg/cray_pointers_1.f90: Update dg-error message. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157512 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 8eea3aca716..5eeead831c4 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2404,8 +2404,8 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, index = gfc_trans_array_bound_check (se, info->descriptor, index, dim, &ar->where, - (ar->as->type != AS_ASSUMED_SIZE - && !ar->as->cp_was_assumed) || dim < ar->dimen - 1); + ar->as->type != AS_ASSUMED_SIZE + || dim < ar->dimen - 1); break; case DIMEN_VECTOR: @@ -2431,8 +2431,8 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, /* Do any bounds checking on the final info->descriptor index. */ index = gfc_trans_array_bound_check (se, info->descriptor, index, dim, &ar->where, - (ar->as->type != AS_ASSUMED_SIZE - && !ar->as->cp_was_assumed) || dim < ar->dimen - 1); + ar->as->type != AS_ASSUMED_SIZE + || dim < ar->dimen - 1); break; case DIMEN_RANGE: @@ -2581,8 +2581,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, /* Upper bound, but not for the last dimension of assumed-size arrays. */ - if (n < ar->dimen - 1 - || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)) + if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE) { tmp = gfc_conv_array_ubound (se->expr, n); if (sym->attr.temporary) @@ -3207,8 +3206,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) continue; if (dim == info->ref->u.ar.dimen - 1 - && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE - || info->ref->u.ar.as->cp_was_assumed)) + && info->ref->u.ar.as->type == AS_ASSUMED_SIZE) check_upper = false; else check_upper = true; -- cgit v1.2.1 From 1384ae99ee84aa34f559ffb29468099e22d88dd2 Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 1 Apr 2010 18:06:05 +0000 Subject: 2010-04-01 Paul Thomas * ioparm.def : Update copyright. * lang.opt : ditto * trans-array.c : ditto * trans-array.h : ditto * expr.c: ditto * trans-types.c: ditto * dependency.c : ditto * gfortran.h : ditto * options.c : ditto * trans-io.c : ditto * trans-intrinsic.c : ditto * libgfortran.h : ditto * invoke.texi : ditto * intrinsic.texi : ditto * trans.c : ditto * trans.h : ditto * intrinsic.c : ditto * interface.c : ditto * iresolve.c : ditto * trans-stmt.c : ditto * trans-stmt.h : ditto * parse,c : ditto * match.h : ditto * error.c : ditto git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157923 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 5eeead831c4..df2846e4148 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1,5 +1,5 @@ /* Array translation routines - 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 -- 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-array.c | 39 +++++++++++++++++++++++++++++++-------- 1 file changed, 31 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index df2846e4148..75516cea554 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5214,7 +5214,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) lse.string_length = rse.string_length; tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, - expr->expr_type == EXPR_VARIABLE); + expr->expr_type == EXPR_VARIABLE, true); gfc_add_expr_to_block (&block, tmp); /* Finish the copying loops. */ @@ -6176,6 +6176,25 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) } +/* Check for default initializer; sym->value is not enough as it is also + set for EXPR_NULL of allocatables. */ + +static bool +has_default_initializer (gfc_symbol *der) +{ + gfc_component *c; + + gcc_assert (der->attr.flavor == FL_DERIVED); + for (c = der->components; c; c = c->next) + if ((c->ts.type != BT_DERIVED && c->initializer) + || (c->ts.type == BT_DERIVED + && (!c->attr.pointer && has_default_initializer (c->ts.u.derived)))) + break; + + return c != NULL; +} + + /* NULLIFY an allocatable/pointer array on function entry, free it on exit. Do likewise, recursively if necessary, with the allocatable components of derived types. */ @@ -6236,17 +6255,21 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) /* Get the descriptor type. */ type = TREE_TYPE (sym->backend_decl); - + if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable)) { - if (!sym->attr.save) + if (!sym->attr.save + && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program)) { - rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&fnblock, tmp); - if (sym->value) + if (sym->value == NULL || !has_default_initializer (sym->ts.u.derived)) + { + rank = sym->as ? sym->as->rank : 0; + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank); + gfc_add_expr_to_block (&fnblock, tmp); + } + else { - tmp = gfc_init_default_dt (sym, NULL); + tmp = gfc_init_default_dt (sym, NULL, false); gfc_add_expr_to_block (&fnblock, tmp); } } -- 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-array.c | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 75516cea554..cbdd8b9c90e 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2531,6 +2531,9 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, gfc_se indexse; gfc_se tmpse; + if (ar->dimen == 0) + return; + /* Handle scalarized references separately. */ if (ar->type != AR_ELEMENT) { @@ -3958,7 +3961,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) /* Find the last reference in the chain. */ while (ref && ref->next != NULL) { - gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); + gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT + || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); prev_ref = ref; ref = ref->next; } @@ -3966,6 +3970,18 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) if (ref == NULL || ref->type != REF_ARRAY) return false; + /* Return if this is a scalar coarray. */ + if (!prev_ref && !expr->symtree->n.sym->attr.dimension) + { + gcc_assert (expr->symtree->n.sym->attr.codimension); + return false; + } + else if (prev_ref && !prev_ref->u.c.component->attr.dimension) + { + gcc_assert (prev_ref->u.c.component->attr.codimension); + return false; + } + if (!prev_ref) allocatable_array = expr->symtree->n.sym->attr.allocatable; else @@ -6361,6 +6377,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) continue; ar = &ref->u.ar; + + if (ar->as->rank == 0) + { + /* Scalar coarray. */ + continue; + } + switch (ar->type) { case AR_ELEMENT: -- 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-array.c | 69 ++++++++++++++++++++++++++--------------------- 1 file changed, 39 insertions(+), 30 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index cbdd8b9c90e..0380049862e 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -86,6 +86,7 @@ along with GCC; see the file COPYING3. If not see #include "real.h" #include "flags.h" #include "gfortran.h" +#include "constructor.h" #include "trans.h" #include "trans-stmt.h" #include "trans-types.h" @@ -94,7 +95,7 @@ along with GCC; see the file COPYING3. If not see #include "dependency.h" static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *); -static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *); +static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); /* The contents of this structure aren't actually used, just the address. */ static gfc_ss gfc_ss_terminator_var; @@ -1014,8 +1015,9 @@ gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr) of array constructor C. */ static bool -gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c) +gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base) { + gfc_constructor *c; gfc_iterator *i; mpz_t val; mpz_t len; @@ -1026,7 +1028,7 @@ gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c) mpz_init (val); dynamic = false; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { i = c->iterator; if (i && gfc_iterator_has_dynamic_bounds (i)) @@ -1231,7 +1233,7 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock, static void gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, - tree desc, gfc_constructor * c, + tree desc, gfc_constructor_base base, tree * poffset, tree * offsetvar, bool dynamic) { @@ -1239,12 +1241,13 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, stmtblock_t body; gfc_se se; mpz_t size; + gfc_constructor *c; tree shadow_loopvar = NULL_TREE; gfc_saved_var saved_loopvar; mpz_init (size); - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { /* If this is an iterator or an array, the offset must be a variable. */ if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)) @@ -1289,7 +1292,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, n = 0; while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) { - p = p->next; + p = gfc_constructor_next (p); n++; } if (n < 4) @@ -1332,7 +1335,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, list = tree_cons (build_int_cst (gfc_array_index_type, idx++), se.expr, list); c = p; - p = p->next; + p = gfc_constructor_next (p); } bound = build_int_cst (NULL_TREE, n - 1); @@ -1585,13 +1588,14 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) Returns TRUE if all elements are character constants. */ bool -get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len) +get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len) { + gfc_constructor *c; bool is_const; - + is_const = TRUE; - if (c == NULL) + if (gfc_constructor_first (base) == NULL) { if (len) *len = build_int_cstu (gfc_charlen_type_node, 0); @@ -1601,7 +1605,8 @@ get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len) /* Loop over all constructor elements to find out is_const, but in len we want to store the length of the first, not the last, element. We can of course exit the loop as soon as is_const is found to be false. */ - for (; c && is_const; c = c->next) + for (c = gfc_constructor_first (base); + c && is_const; c = gfc_constructor_next (c)) { switch (c->expr->expr_type) { @@ -1641,17 +1646,18 @@ get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len) return zero. Note, an empty or NULL array constructor returns zero. */ unsigned HOST_WIDE_INT -gfc_constant_array_constructor_p (gfc_constructor * c) +gfc_constant_array_constructor_p (gfc_constructor_base base) { unsigned HOST_WIDE_INT nelem = 0; + gfc_constructor *c = gfc_constructor_first (base); while (c) { if (c->iterator || c->expr->rank > 0 || c->expr->expr_type != EXPR_CONSTANT) return 0; - c = c->next; + c = gfc_constructor_next (c); nelem++; } return nelem; @@ -1676,7 +1682,7 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type) to tree to build an initializer. */ nelem = 0; list = NULL_TREE; - c = expr->value.constructor; + c = gfc_constructor_first (expr->value.constructor); while (c) { gfc_init_se (&se, NULL); @@ -1688,7 +1694,7 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type) se.expr); list = tree_cons (build_int_cst (gfc_array_index_type, nelem), se.expr, list); - c = c->next; + c = gfc_constructor_next (c); nelem++; } @@ -1702,15 +1708,17 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type) as.type = AS_EXPLICIT; if (!expr->shape) { - as.lower[0] = gfc_int_expr (0); - as.upper[0] = gfc_int_expr (nelem - 1); + as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, nelem - 1); } else for (i = 0; i < expr->rank; i++) { int tmp = (int) mpz_get_si (expr->shape[i]); - as.lower[i] = gfc_int_expr (0); - as.upper[i] = gfc_int_expr (tmp - 1); + as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, tmp - 1); } tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); @@ -1807,7 +1815,7 @@ constant_array_constructor_loop_size (gfc_loopinfo * loop) static void gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) { - gfc_constructor *c; + gfc_constructor_base c; tree offset; tree offsetvar; tree desc; @@ -3557,7 +3565,6 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) tree tmp; gfc_ss *loopspec[GFC_MAX_DIMENSIONS]; bool dynamic[GFC_MAX_DIMENSIONS]; - gfc_constructor *c; mpz_t *cshape; mpz_t i; @@ -3582,6 +3589,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) if (ss->type == GFC_SS_CONSTRUCTOR) { + gfc_constructor_base base; /* An unknown size constructor will always be rank one. Higher rank constructors will either have known shape, or still be wrapped in a call to reshape. */ @@ -3591,8 +3599,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) can be determined at compile time. Prefer not to otherwise, since the general case involves realloc, and it's better to avoid that overhead if possible. */ - c = ss->expr->value.constructor; - dynamic[n] = gfc_get_array_constructor_size (&i, c); + base = ss->expr->value.constructor; + dynamic[n] = gfc_get_array_constructor_size (&i, base); if (!dynamic[n] || !loopspec[n]) loopspec[n] = ss; continue; @@ -4117,7 +4125,8 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) case EXPR_ARRAY: /* Create a vector of all the elements. */ - for (c = expr->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) { if (c->iterator) { @@ -4130,8 +4139,8 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) gfc_option.flag_max_array_constructor); return NULL_TREE; } - if (mpz_cmp_si (c->n.offset, 0) != 0) - index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind); + if (mpz_cmp_si (c->offset, 0) != 0) + index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); else index = NULL_TREE; mpz_init (maxval); @@ -4140,16 +4149,16 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) tree tmp1, tmp2; mpz_set (maxval, c->repeat); - mpz_add (maxval, c->n.offset, maxval); + mpz_add (maxval, c->offset, maxval); mpz_sub_ui (maxval, maxval, 1); tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - if (mpz_cmp_si (c->n.offset, 0) != 0) + if (mpz_cmp_si (c->offset, 0) != 0) { - mpz_add_ui (maxval, c->n.offset, 1); + mpz_add_ui (maxval, c->offset, 1); tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); } else - tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind); + tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2); } -- cgit v1.2.1 From 26b20b07032201013d6e503ead070698ccf6ef67 Mon Sep 17 00:00:00 2001 From: kargl Date: Thu, 15 Apr 2010 21:32:21 +0000 Subject: PR fortran/30073 * trans-array.c (gfc_trans_array_bound_check): Eliminate a redundant block of code. Set name to the variable associated with the descriptor. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158392 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0380049862e..a880f0efe61 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2324,10 +2324,6 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, && se->loop->ss->loop_chain->expr->symtree) name = se->loop->ss->loop_chain->expr->symtree->name; - if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain - && se->loop->ss->loop_chain->expr->symtree) - name = se->loop->ss->loop_chain->expr->symtree->name; - if (!name && se->loop && se->loop->ss && se->loop->ss->expr) { if (se->loop->ss->expr->expr_type == EXPR_FUNCTION @@ -2339,6 +2335,9 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, name = "unnamed constant"; } + if (descriptor->base.code != COMPONENT_REF) + name = IDENTIFIER_POINTER (DECL_NAME (descriptor)); + /* If upper bound is present, include both bounds in the error message. */ if (check_upper) { -- cgit v1.2.1 From f10ca8ea5d9cb6a4dad0b1c64806be1baf3a5c5f Mon Sep 17 00:00:00 2001 From: kargl Date: Sat, 17 Apr 2010 21:05:53 +0000 Subject: 2010-04-17 Steven G. Kargl PR fortran/31538 * gfortran.dg/bounds_check_fail_4.f90: Adjust error message. * gfortran.dg/bounds_check_fail_3.f90: Ditto. 2010-04-17 Steven G. Kargl PR fortran/31538 * fortran/trans-array.c (gfc_conv_ss_startstride): Remove the use of gfc_msg_bounds by using 'Array bound mismatch' directly. (gfc_trans_dummy_array_bias): Remove the use of gfc_msg_bounds. Reword error message to include the mismatch in the extent of array bound. * fortran/trans.c: Remove gfc_msg_bounds. It is only used in one place. * fortran/trans.h: Remove extern definition of gfc_msg_bounds. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158474 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 31 ++++++++++++++++++++++--------- 1 file changed, 22 insertions(+), 9 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a880f0efe61..b03cc9400c9 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3365,13 +3365,15 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) if (size[n]) { tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]); - asprintf (&msg, "%s, size mismatch for dimension %d " - "of array '%s' (%%ld/%%ld)", gfc_msg_bounds, + asprintf (&msg, "Array bound mismatch for dimension %d " + "of array '%s' (%%ld/%%ld)", info->dim[n]+1, ss->expr->symtree->name); + gfc_trans_runtime_check (true, false, tmp3, &inner, &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp), fold_convert (long_integer_type_node, size[n])); + gfc_free (msg); } else @@ -4632,15 +4634,26 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) { /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ char * msg; + tree temp; - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - ubound, lbound); - stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, + temp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + ubound, lbound); + temp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + gfc_index_one_node, temp); + + stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound); - tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2); - asprintf (&msg, "%s for dimension %d of array '%s'", - gfc_msg_bounds, n+1, sym->name); - gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg); + stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type, + gfc_index_one_node, stride2); + + tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2); + asprintf (&msg, "Dimension %d of array '%s' has extent " + "%%ld instead of %%ld", n+1, sym->name); + + gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg, + fold_convert (long_integer_type_node, temp), + fold_convert (long_integer_type_node, stride2)); + gfc_free (msg); } } -- cgit v1.2.1 From e2ab564d100612d6415ce2dc2e7dc19024ae2bc7 Mon Sep 17 00:00:00 2001 From: rguenth Date: Thu, 22 Apr 2010 08:34:41 +0000 Subject: 2010-04-22 Richard Guenther PR fortran/43829 * resolve.c (gfc_resolve_index): Wrap around ... (gfc_resolve_index_1): ... this. Add parameter to allow any integer kind index type. (resolve_array_ref): Allow any integer kind for the start index of an array ref. * gfortran.dg/vector_subscript_6.f90: New testcase. * gfortran.dg/assign_10.f90: Adjust. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158632 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b03cc9400c9..199eb23b6ac 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2434,6 +2434,7 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, gfc_conv_array_data (desc)); index = gfc_build_array_ref (data, index, NULL); index = gfc_evaluate_now (index, &se->pre); + index = fold_convert (gfc_array_index_type, index); /* Do any bounds checking on the final info->descriptor index. */ index = gfc_trans_array_bound_check (se, info->descriptor, -- 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-array.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 199eb23b6ac..c3a92bc320e 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2054,9 +2054,10 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, break; case GFC_SS_REFERENCE: - /* Scalar reference. Evaluate this now. */ + /* Scalar argument to elemental procedure. Evaluate this + now. */ gfc_init_se (&se, NULL); - gfc_conv_expr_reference (&se, ss->expr); + gfc_conv_expr (&se, ss->expr); gfc_add_block_to_block (&loop->pre, &se.pre); gfc_add_block_to_block (&loop->post, &se.post); -- cgit v1.2.1 From 7f14c1e0b9577ac6b61cada410ea2aa912ccb17a Mon Sep 17 00:00:00 2001 From: kargl Date: Sat, 24 Apr 2010 20:32:04 +0000 Subject: 2010-04-24 Steven G. Kargl PR fortran/30073 PR fortran/43793 * trans-array.c (gfc_trans_array_bound_check): Use TREE_CODE instead of mucking with a tree directly. 2010-04-24 Steven G. Kargl PR fortran/30073 PR fortran/43793 gfortran.dg/pr43793.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158692 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c3a92bc320e..1b56189d941 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2336,7 +2336,7 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, name = "unnamed constant"; } - if (descriptor->base.code != COMPONENT_REF) + if (TREE_CODE (descriptor) == VAR_DECL) name = IDENTIFIER_POINTER (DECL_NAME (descriptor)); /* If upper bound is present, include both bounds in the error message. */ -- cgit v1.2.1 From 6ddcd499e191351f9cf850c4a7d23eb6ad3ca4de Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 27 Apr 2010 08:41:00 +0000 Subject: 2010-04-27 Tobias Burnus PR fortran/18918 * resolve.c (resolve_allocate_expr): Allow array coarrays. * trans-types.h (gfc_get_array_type_bounds): Update prototype. * trans-types.c (gfc_get_array_type_bounds, gfc_get_array_descriptor_base): Add corank argument. * trans-array.c (gfc_array_init_size): Handle corank. (gfc_trans_create_temp_array, gfc_array_allocate, gfc_conv_expr_descriptor): Add corank argument to call. * trans-stmt.c (gfc_trans_pointer_assign_need_temp): Ditto. 2010-04-27 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_7.f90: Modified and removed obsolete tests. * gfortran.dg/coarray_12.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158768 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 92 ++++++++++++++++++++++++++++++++++------------- 1 file changed, 68 insertions(+), 24 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 1b56189d941..e20406c9451 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -725,7 +725,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, /* Initialize the descriptor. */ type = - gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1, + gfc_get_array_type_bounds (eltype, info->dimen, 0, loop->from, loop->to, 1, GFC_ARRAY_UNKNOWN, true); desc = gfc_create_var (type, "atmp"); GFC_DECL_PACKED_ARRAY (desc) = 1; @@ -3819,7 +3819,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) /*GCC ARRAYS*/ static tree -gfc_array_init_size (tree descriptor, int rank, tree * poffset, +gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock) { @@ -3917,6 +3917,43 @@ gfc_array_init_size (tree descriptor, int rank, tree * poffset, stride = gfc_evaluate_now (stride, pblock); } + for (n = rank; n < rank + corank; n++) + { + ubound = upper[n]; + + /* Set lower bound. */ + gfc_init_se (&se, NULL); + if (lower == NULL || lower[n] == NULL) + { + gcc_assert (n == rank + corank - 1); + se.expr = gfc_index_one_node; + } + else + { + if (ubound || n == rank + corank - 1) + { + gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + } + else + { + se.expr = gfc_index_one_node; + ubound = lower[n]; + } + } + gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n], + se.expr); + + if (n < rank + corank - 1) + { + gfc_init_se (&se, NULL); + gcc_assert (ubound); + gfc_conv_expr_type (&se, ubound, gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr); + } + } + /* The stride is the number of elements in the array, so multiply by the size of an element to get the total size. */ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); @@ -3965,7 +4002,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) gfc_expr **lower; gfc_expr **upper; gfc_ref *ref, *prev_ref = NULL; - bool allocatable_array; + bool allocatable_array, coarray; ref = expr->ref; @@ -3981,29 +4018,40 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) if (ref == NULL || ref->type != REF_ARRAY) return false; - /* Return if this is a scalar coarray. */ - if (!prev_ref && !expr->symtree->n.sym->attr.dimension) + if (!prev_ref) { - gcc_assert (expr->symtree->n.sym->attr.codimension); - return false; + allocatable_array = expr->symtree->n.sym->attr.allocatable; + coarray = expr->symtree->n.sym->attr.codimension; } - else if (prev_ref && !prev_ref->u.c.component->attr.dimension) + else { - gcc_assert (prev_ref->u.c.component->attr.codimension); - return false; + allocatable_array = prev_ref->u.c.component->attr.allocatable; + coarray = prev_ref->u.c.component->attr.codimension; } - if (!prev_ref) - allocatable_array = expr->symtree->n.sym->attr.allocatable; - else - allocatable_array = prev_ref->u.c.component->attr.allocatable; + /* Return if this is a scalar coarray. */ + if ((!prev_ref && !expr->symtree->n.sym->attr.dimension) + || (prev_ref && !prev_ref->u.c.component->attr.dimension)) + { + gcc_assert (coarray); + return false; + } /* Figure out the size of the array. */ switch (ref->u.ar.type) { case AR_ELEMENT: - lower = NULL; - upper = ref->u.ar.start; + if (!coarray) + { + lower = NULL; + upper = ref->u.ar.start; + break; + } + /* Fall through. */ + + case AR_SECTION: + lower = ref->u.ar.start; + upper = ref->u.ar.end; break; case AR_FULL: @@ -4013,18 +4061,14 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) upper = ref->u.ar.as->upper; break; - case AR_SECTION: - lower = ref->u.ar.start; - upper = ref->u.ar.end; - break; - default: gcc_unreachable (); break; } - size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset, - lower, upper, &se->pre); + size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, + ref->u.ar.as->corank, &offset, lower, upper, + &se->pre); /* Allocate memory to store the data. */ pointer = gfc_conv_descriptor_data_get (se->expr); @@ -5299,7 +5343,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) { /* Otherwise make a new one. */ parmtype = gfc_get_element_type (TREE_TYPE (desc)); - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, loop.from, loop.to, 0, GFC_ARRAY_UNKNOWN, false); parm = gfc_create_var (parmtype, "parm"); -- cgit v1.2.1 From 53ee584785ce94d834c0679ed8a6abb6a7c89e99 Mon Sep 17 00:00:00 2001 From: dfranke Date: Wed, 5 May 2010 18:53:23 +0000 Subject: gcc/fortran/: 2010-05-05 Daniel Franke PR fortran/24978 * gfortran.h: Removed repeat count from constructor, removed all usages. * data.h (gfc_assign_data_value_range): Changed return value from void to gfc_try. * data.c (gfc_assign_data_value): Add location to constructor element. (gfc_assign_data_value_range): Call gfc_assign_data_value() for each element in range. Return early if an error was generated. * resolve.c (check_data_variable): Stop early if range assignment generated an error. gcc/testsuite/: 2010-05-05 Daniel Franke PR fortran/24978 * gfortran.dg/data_invalid.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159076 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 43 +++---------------------------------------- 1 file changed, 3 insertions(+), 40 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index e20406c9451..8ece64327af 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4133,11 +4133,10 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) { gfc_constructor *c; tree tmp; - mpz_t maxval; gfc_se se; HOST_WIDE_INT hi; unsigned HOST_WIDE_INT lo; - tree index, range; + tree index; VEC(constructor_elt,gc) *v = NULL; switch (expr->expr_type) @@ -4190,42 +4189,13 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); else index = NULL_TREE; - mpz_init (maxval); - if (mpz_cmp_si (c->repeat, 0) != 0) - { - tree tmp1, tmp2; - - mpz_set (maxval, c->repeat); - mpz_add (maxval, c->offset, maxval); - mpz_sub_ui (maxval, maxval, 1); - tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - if (mpz_cmp_si (c->offset, 0) != 0) - { - mpz_add_ui (maxval, c->offset, 1); - tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - } - else - tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); - - range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2); - } - else - range = NULL; - mpz_clear (maxval); gfc_init_se (&se, NULL); switch (c->expr->expr_type) { case EXPR_CONSTANT: gfc_conv_constant (&se, c->expr); - if (range == NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - else - { - if (index != NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - CONSTRUCTOR_APPEND_ELT (v, range, se.expr); - } + CONSTRUCTOR_APPEND_ELT (v, index, se.expr); break; case EXPR_STRUCTURE: @@ -4239,14 +4209,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) for one reason or another, assuming that if they are standard defying the frontend will catch them. */ gfc_conv_expr (&se, c->expr); - if (range == NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - else - { - if (index != NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - CONSTRUCTOR_APPEND_ELT (v, range, se.expr); - } + CONSTRUCTOR_APPEND_ELT (v, index, se.expr); break; } } -- cgit v1.2.1 From 06f13dc11eae7a9ff64a9412af722a4945f30482 Mon Sep 17 00:00:00 2001 From: froydnj Date: Mon, 17 May 2010 16:03:46 +0000 Subject: * trans-array.c (gfc_trans_array_constructor_value): Use build_constructor instead of build_constructor_from_list. (gfc_build_constant_array_constructor): Likewise. * trans-decl.c (create_main_function): Likewise. * trans-stmt.c (gfc_trans_character_select): Likewise. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159490 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 8ece64327af..a94c8d2b3c5 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1308,14 +1308,13 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, else { /* Collect multiple scalar constants into a constructor. */ - tree list; + VEC(constructor_elt,gc) *v = NULL; tree init; tree bound; tree tmptype; HOST_WIDE_INT idx = 0; p = c; - list = NULL_TREE; /* Count the number of consecutive scalar constants. */ while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) @@ -1332,8 +1331,10 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, (gfc_get_pchar_type (p->expr->ts.kind), se.expr); - list = tree_cons (build_int_cst (gfc_array_index_type, - idx++), se.expr, list); + CONSTRUCTOR_APPEND_ELT (v, + build_int_cst (gfc_array_index_type, + idx++), + se.expr); c = p; p = gfc_constructor_next (p); } @@ -1344,7 +1345,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, gfc_index_zero_node, bound); tmptype = build_array_type (type, tmptype); - init = build_constructor_from_list (tmptype, nreverse (list)); + init = build_constructor (tmptype, v); TREE_CONSTANT (init) = 1; TREE_STATIC (init) = 1; /* Create a static variable to hold the data. */ @@ -1671,17 +1672,17 @@ gfc_constant_array_constructor_p (gfc_constructor_base base) tree gfc_build_constant_array_constructor (gfc_expr * expr, tree type) { - tree tmptype, list, init, tmp; + tree tmptype, init, tmp; HOST_WIDE_INT nelem; gfc_constructor *c; gfc_array_spec as; gfc_se se; int i; + VEC(constructor_elt,gc) *v = NULL; /* First traverse the constructor list, converting the constants to tree to build an initializer. */ nelem = 0; - list = NULL_TREE; c = gfc_constructor_first (expr->value.constructor); while (c) { @@ -1692,8 +1693,8 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type) else if (POINTER_TYPE_P (type)) se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), se.expr); - list = tree_cons (build_int_cst (gfc_array_index_type, nelem), - se.expr, list); + CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem), + se.expr); c = gfc_constructor_next (c); nelem++; } @@ -1723,7 +1724,7 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type) tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); - init = build_constructor_from_list (tmptype, nreverse (list)); + init = build_constructor (tmptype, v); TREE_CONSTANT (init) = 1; TREE_STATIC (init) = 1; -- cgit v1.2.1 From 0826251092361171d72575cd36d4578e22cf9e9e Mon Sep 17 00:00:00 2001 From: dfranke Date: Wed, 19 May 2010 13:07:25 +0000 Subject: gcc/fortran/: 2010-05-19 Daniel Franke PR fortran/42360 * gfortran.h (gfc_has_default_initializer): New. * expr.c (gfc_has_default_initializer): New. * resolve.c (has_default_initializer): Removed, use gfc_has_default_initializer() instead. Updated all callers. * trans-array.c (has_default_initializer): Removed, use gfc_has_default_initializer() instead. Updated all callers. * trans-decl.c (generate_local_decl): Do not check the first component only to check for initializers, but use gfc_has_default_initializer() instead. gcc/testsuite/: 2010-05-19 Daniel Franke PR fortran/42360 * gfortran.dg/warn_intent_out_not_set.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159562 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 22 ++-------------------- 1 file changed, 2 insertions(+), 20 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a94c8d2b3c5..7f81cf1af47 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6223,25 +6223,6 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) } -/* Check for default initializer; sym->value is not enough as it is also - set for EXPR_NULL of allocatables. */ - -static bool -has_default_initializer (gfc_symbol *der) -{ - gfc_component *c; - - gcc_assert (der->attr.flavor == FL_DERIVED); - for (c = der->components; c; c = c->next) - if ((c->ts.type != BT_DERIVED && c->initializer) - || (c->ts.type == BT_DERIVED - && (!c->attr.pointer && has_default_initializer (c->ts.u.derived)))) - break; - - return c != NULL; -} - - /* NULLIFY an allocatable/pointer array on function entry, free it on exit. Do likewise, recursively if necessary, with the allocatable components of derived types. */ @@ -6308,7 +6289,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) if (!sym->attr.save && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program)) { - if (sym->value == NULL || !has_default_initializer (sym->ts.u.derived)) + if (sym->value == NULL + || !gfc_has_default_initializer (sym->ts.u.derived)) { rank = sym->as ? sym->as->rank : 0; tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank); -- 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-array.c | 5 ----- 1 file changed, 5 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 7f81cf1af47..1f6021a2989 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -80,10 +80,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "gimple.h" -#include "ggc.h" #include "toplev.h" -#include "real.h" #include "flags.h" #include "gfortran.h" #include "constructor.h" @@ -5268,8 +5265,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gfc_trans_scalarizing_loops (&loop, &block); desc = loop.temp_ss->data.info.descriptor; - - gcc_assert (is_gimple_lvalue (desc)); } else if (expr->expr_type == EXPR_FUNCTION) { -- 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-array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 1f6021a2989..ddfe40f7a54 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -80,7 +80,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 internal_error/fatal_error. */ #include "flags.h" #include "gfortran.h" #include "constructor.h" -- cgit v1.2.1 From 50b4b37ba4128b5e02d6b8af5f872770063c1d2b Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 30 May 2010 21:56:11 +0000 Subject: 2010-05-30 Janus Weil * gcc/fortran/gfortran.h (CLASS_DATA): New macro for accessing the $data component of a class container. * gcc/fortran/decl.c (attr_decl1): Use macro CLASS_DATA. * gcc/fortran/expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol, gfc_has_ultimate_allocatable,gfc_has_ultimate_pointer): Ditto. * gcc/fortran/interface.c (matching_typebound_op): Ditto. * gcc/fortran/match.c (gfc_match_allocate, gfc_match_deallocate): Ditto. * gcc/fortran/parse.c (parse_derived): Ditto. * gcc/fortran/primary.c (gfc_match_varspec, gfc_variable_attr, gfc_expr_attr): Ditto. * gcc/fortran/resolve.c (resolve_structure_cons, find_array_spec, resolve_deallocate_expr, resolve_allocate_expr, resolve_select_type, resolve_fl_var_and_proc, resolve_typebound_procedure, resolve_fl_derived): Ditto. * gcc/fortran/symbol.c (gfc_type_compatible): Restructured. * gcc/fortran/trans-array.c (structure_alloc_comps): Use macro CLASS_DATA. * gcc/fortran/trans-decl.c (gfc_get_symbol_decl, gfc_trans_deferred_vars): Ditto. * gcc/fortran/trans-stmt.c (gfc_trans_allocate): Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160060 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ddfe40f7a54..7d7b3a36839 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6079,14 +6079,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); } - else if (c->ts.type == BT_CLASS - && c->ts.u.derived->components->attr.allocatable) + else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { /* Allocatable scalar CLASS components. */ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); /* Add reference to '$data' component. */ - tmp = c->ts.u.derived->components->backend_decl; + tmp = CLASS_DATA (c)->backend_decl; comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), comp, tmp, NULL_TREE); @@ -6116,13 +6115,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); } - else if (c->ts.type == BT_CLASS - && c->ts.u.derived->components->attr.allocatable) + else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { /* Allocatable scalar CLASS components. */ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); /* Add reference to '$data' component. */ - tmp = c->ts.u.derived->components->backend_decl; + tmp = CLASS_DATA (c)->backend_decl; comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), comp, tmp, NULL_TREE); tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp, -- cgit v1.2.1 From 76e5b0d8c5279b7e76980983699fedebe5ab70e0 Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 5 Jun 2010 17:51:39 +0000 Subject: 2010-06-05 Paul Thomas PR fortran/43895 * trans-array.c (structure_alloc_comps): Dereference scalar 'decl' if it is a REFERENCE_TYPE. Tidy expressions containing TREE_TYPE (decl). 2010-06-05 Paul Thomas PR fortran/43895 * gfortran.dg/alloc_comp_class_1.f90 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160326 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 7d7b3a36839..575dd0258a1 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5938,6 +5938,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_loopinfo loop; stmtblock_t fnblock; stmtblock_t loopbody; + tree decl_type; tree tmp; tree comp; tree dcmp; @@ -5951,21 +5952,28 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_init_block (&fnblock); - if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0) + decl_type = TREE_TYPE (decl); + + if ((POINTER_TYPE_P (decl_type) && rank != 0) + || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) + decl = build_fold_indirect_ref_loc (input_location, decl); + /* Just in case in gets dereferenced. */ + decl_type = TREE_TYPE (decl); + /* If this an array of derived types with allocatable components build a loop and recursively call this function. */ - if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE - || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + if (TREE_CODE (decl_type) == ARRAY_TYPE + || GFC_DESCRIPTOR_TYPE_P (decl_type)) { tmp = gfc_conv_array_data (decl); var = build_fold_indirect_ref_loc (input_location, tmp); /* Get the number of elements - 1 and set the counter. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + if (GFC_DESCRIPTOR_TYPE_P (decl_type)) { /* Use the descriptor for an allocatable array. Since this is a full array reference, we only need the descriptor @@ -5981,7 +5989,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, else { /* Otherwise use the TYPE_DOMAIN information. */ - tmp = array_type_nelts (TREE_TYPE (decl)); + tmp = array_type_nelts (decl_type); tmp = fold_convert (gfc_array_index_type, tmp); } @@ -5998,7 +6006,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) { - tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank); + tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank); gfc_add_expr_to_block (&fnblock, tmp); } tmp = build_fold_indirect_ref_loc (input_location, -- 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-array.c | 47 ++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 42 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 575dd0258a1..7eb8e755785 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -285,7 +285,9 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim) tree type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); if (integer_zerop (dim) - && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) + && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) return gfc_index_one_node; return gfc_conv_descriptor_stride (desc, dim); @@ -5522,6 +5524,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, ultimate_ptr_comp = false; ultimate_alloc_comp = false; + for (ref = expr->ref; ref; ref = ref->next) { if (ref->next == NULL) @@ -5608,7 +5611,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, contiguous = g77 && !this_array_result && contiguous; /* There is no need to pack and unpack the array, if it is contiguous - and not deferred or assumed shape. */ + and not a deferred- or assumed-shape array, or if it is simply + contiguous. */ no_pack = ((sym && sym->as && !sym->attr.pointer && sym->as->type != AS_DEFERRED @@ -5616,7 +5620,9 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, || (ref && ref->u.ar.as && ref->u.ar.as->type != AS_DEFERRED - && ref->u.ar.as->type != AS_ASSUMED_SHAPE)); + && ref->u.ar.as->type != AS_ASSUMED_SHAPE) + || + gfc_is_simply_contiguous (expr, false)); no_pack = contiguous && no_pack; @@ -5680,9 +5686,24 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, gfc_add_expr_to_block (&se->post, tmp); } - if (g77) + if (g77 || (fsym && fsym->attr.contiguous + && !gfc_is_simply_contiguous (expr, false))) { + tree origptr = NULL_TREE; + desc = se->expr; + + /* For contiguous arrays, save the original value of the descriptor. */ + if (!g77) + { + origptr = gfc_create_var (pvoid_type_node, "origptr"); + tmp = build_fold_indirect_ref_loc (input_location, desc); + tmp = gfc_conv_array_data (tmp); + tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (origptr), origptr, + fold_convert (TREE_TYPE (origptr), tmp)); + gfc_add_expr_to_block (&se->pre, tmp); + } + /* Repack the array. */ if (gfc_option.warn_array_temp) { @@ -5706,7 +5727,15 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, ptr = gfc_evaluate_now (ptr, &se->pre); - se->expr = ptr; + /* Use the packed data for the actual argument, except for contiguous arrays, + where the descriptor's data component is set. */ + if (g77) + se->expr = ptr; + else + { + tmp = build_fold_indirect_ref_loc (input_location, desc); + gfc_conv_descriptor_data_set (&se->pre, tmp, ptr); + } if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) { @@ -5768,6 +5797,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, gfc_add_block_to_block (&block, &se->post); gfc_init_block (&se->post); + + /* Reset the descriptor pointer. */ + if (!g77) + { + tmp = build_fold_indirect_ref_loc (input_location, desc); + gfc_conv_descriptor_data_set (&se->post, tmp, origptr); + } + gfc_add_block_to_block (&se->post, &block); } } -- 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-array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 7eb8e755785..bc268357c9b 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -80,7 +80,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "toplev.h" /* For internal_error/fatal_error. */ +#include "diagnostic-core.h" /* For internal_error/fatal_error. */ #include "flags.h" #include "gfortran.h" #include "constructor.h" -- cgit v1.2.1 From 3ab0a97bd4d0027bf8d8753844b5cf3c3435c461 Mon Sep 17 00:00:00 2001 From: mikael Date: Wed, 14 Jul 2010 19:19:57 +0000 Subject: 2010-07-14 Mikael Morin * trans-array.c (gfc_conv_section_upper_bound): Remove (gfc_conv_section_startstride): Don't set the upper bound in the vector subscript case. (gfc_conv_loop_setup): Don't use gfc_conv_section_upper_bound git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162191 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 58 ++++------------------------------------------- 1 file changed, 5 insertions(+), 53 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index bc268357c9b..b6a95483ea6 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2964,50 +2964,6 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) } -/* Calculate the upper bound of an array section. */ - -static tree -gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock) -{ - int dim; - gfc_expr *end; - tree desc; - tree bound; - gfc_se se; - gfc_ss_info *info; - - gcc_assert (ss->type == GFC_SS_SECTION); - - info = &ss->data.info; - dim = info->dim[n]; - - if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) - /* We'll calculate the upper bound once we have access to the - vector's descriptor. */ - return NULL; - - gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE); - desc = info->descriptor; - end = info->ref->u.ar.end[dim]; - - if (end) - { - /* The upper bound was specified. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, end, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - bound = se.expr; - } - else - { - /* No upper bound was specified, so use the bound of the array. */ - bound = gfc_conv_array_ubound (desc, dim); - } - - return bound; -} - - /* Calculate the lower bound of an array section. */ static void @@ -3030,8 +2986,8 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) { /* We use a zero-based index to access the vector. */ info->start[n] = gfc_index_zero_node; - info->end[n] = gfc_index_zero_node; info->stride[n] = gfc_index_one_node; + info->end[n] = NULL; return; } @@ -3688,17 +3644,13 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) case GFC_SS_SECTION: /* Use the end expression if it exists and is not constant, so that it is only evaluated once. */ - if (info->end[n] && !INTEGER_CST_P (info->end[n])) - loop->to[n] = info->end[n]; - else - loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n, - &loop->pre); + loop->to[n] = info->end[n]; break; - case GFC_SS_FUNCTION: + case GFC_SS_FUNCTION: /* The loop bound will be set when we generate the call. */ - gcc_assert (loop->to[n] == NULL_TREE); - break; + gcc_assert (loop->to[n] == NULL_TREE); + break; default: gcc_unreachable (); -- cgit v1.2.1 From c5faa79924f2b5c58fd21b6bd2416836985dfc25 Mon Sep 17 00:00:00 2001 From: domob Date: Thu, 15 Jul 2010 12:23:47 +0000 Subject: 2010-07-15 Daniel Kraft PR fortran/44709 * trans.h (struct gfc_wrapped_block): New struct. (gfc_start_wrapped_block), (gfc_add_init_cleanup): New methods. (gfc_finish_wrapped_block): New method. (gfc_init_default_dt): Add new init code to block rather than returning it. * trans-array.h (gfc_trans_auto_array_allocation): Use gfc_wrapped_block (gfc_trans_dummy_array_bias): Ditto. (gfc_trans_g77_array): Ditto. (gfc_trans_deferred_array): Ditto. * trans.c (gfc_add_expr_to_block): Call add_expr_to_chain. (add_expr_to_chain): New method based on old gfc_add_expr_to_block. (gfc_start_wrapped_block), (gfc_add_init_cleanup): New methods. (gfc_finish_wrapped_block): New method. * trans-array.c (gfc_trans_auto_array_allocation): use gfc_wrapped_block (gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto. (gfc_trans_deferred_array): Ditto. * trans-decl.c (gfc_trans_dummy_character): Ditto. (gfc_trans_auto_character_variable), (gfc_trans_assign_aux_var): Ditto. (init_intent_out_dt): Ditto. (gfc_init_default_dt): Add new init code to block rather than returning it. (gfc_trans_deferred_vars): Use gfc_wrapped_block to collect all init and cleanup code and put it all together. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162219 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 297 ++++++++++++++++++++++------------------------ 1 file changed, 143 insertions(+), 154 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b6a95483ea6..6dfb0699346 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4265,10 +4265,11 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, /* Generate code to initialize/allocate an array variable. */ -tree -gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) +void +gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, + gfc_wrapped_block * block) { - stmtblock_t block; + stmtblock_t init; tree type; tree tmp; tree size; @@ -4279,32 +4280,32 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) /* Do nothing for USEd variables. */ if (sym->attr.use_assoc) - return fnbody; + return; type = TREE_TYPE (decl); gcc_assert (GFC_ARRAY_TYPE_P (type)); onstack = TREE_CODE (type) != POINTER_TYPE; - gfc_start_block (&block); + gfc_start_block (&init); /* Evaluate character string length. */ if (sym->ts.type == BT_CHARACTER && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &block); + gfc_trans_vla_type_sizes (sym, &init); /* Emit a DECL_EXPR for this variable, which will cause the gimplifier to allocate storage, and all that good stuff. */ tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl); - gfc_add_expr_to_block (&block, tmp); + gfc_add_expr_to_block (&init, tmp); } if (onstack) { - gfc_add_expr_to_block (&block, fnbody); - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } type = TREE_TYPE (type); @@ -4315,17 +4316,18 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - size = gfc_trans_array_bounds (type, sym, &offset, &block); + size = gfc_trans_array_bounds (type, sym, &offset, &init); /* Don't actually allocate space for Cray Pointees. */ if (sym->attr.cray_pointee) { if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - gfc_add_expr_to_block (&block, fnbody); - return gfc_finish_block (&block); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } /* The size is the number of elements in the array, so multiply by the @@ -4335,31 +4337,27 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) fold_convert (gfc_array_index_type, tmp)); /* Allocate memory to hold the data. */ - tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size); - gfc_add_modify (&block, decl, tmp); + tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size); + gfc_add_modify (&init, decl, tmp); /* Set offset of the array. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); /* Automatic arrays should not have initializers. */ gcc_assert (!sym->value); - gfc_add_expr_to_block (&block, fnbody); - /* Free the temporary. */ tmp = gfc_call_free (convert (pvoid_type_node, decl)); - gfc_add_expr_to_block (&block, tmp); - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); } /* Generate entry and exit code for g77 calling convention arrays. */ -tree -gfc_trans_g77_array (gfc_symbol * sym, tree body) +void +gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) { tree parm; tree type; @@ -4367,7 +4365,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) tree offset; tree tmp; tree stmt; - stmtblock_t block; + stmtblock_t init; gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -4377,31 +4375,29 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) type = TREE_TYPE (parm); gcc_assert (GFC_ARRAY_TYPE_P (type)); - gfc_start_block (&block); + gfc_start_block (&init); if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); /* Evaluate the bounds of the array. */ - gfc_trans_array_bounds (type, sym, &offset, &block); + gfc_trans_array_bounds (type, sym, &offset, &init); /* Set the offset. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); /* Set the pointer itself if we aren't using the parameter directly. */ if (TREE_CODE (parm) != PARM_DECL) { tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm)); - gfc_add_modify (&block, parm, tmp); + gfc_add_modify (&init, parm, tmp); } - stmt = gfc_finish_block (&block); + stmt = gfc_finish_block (&init); gfc_set_backend_locus (&loc); - gfc_start_block (&block); - /* Add the initialization code to the start of the function. */ if (sym->attr.optional || sym->attr.not_always_present) @@ -4410,10 +4406,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&block, stmt); - gfc_add_expr_to_block (&block, body); - - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, stmt, NULL_TREE); } @@ -4428,22 +4421,22 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) Code is also added to copy the data back at the end of the function. */ -tree -gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) +void +gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, + gfc_wrapped_block * block) { tree size; tree type; tree offset; locus loc; - stmtblock_t block; - stmtblock_t cleanup; + stmtblock_t init; + tree stmtInit, stmtCleanup; tree lbound; tree ubound; tree dubound; tree dlbound; tree dumdesc; tree tmp; - tree stmt; tree stride, stride2; tree stmt_packed; tree stmt_unpacked; @@ -4456,10 +4449,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) /* Do nothing for pointer and allocatable arrays. */ if (sym->attr.pointer || sym->attr.allocatable) - return body; + return; if (sym->attr.dummy && gfc_is_nodesc_array (sym)) - return gfc_trans_g77_array (sym, body); + { + gfc_trans_g77_array (sym, block); + return; + } gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -4468,35 +4464,32 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) type = TREE_TYPE (tmpdesc); gcc_assert (GFC_ARRAY_TYPE_P (type)); dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - dumdesc = build_fold_indirect_ref_loc (input_location, - dumdesc); - gfc_start_block (&block); + dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); + gfc_start_block (&init); if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); checkparm = (sym->as->type == AS_EXPLICIT && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) - || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); + || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)) { /* For non-constant shape arrays we only check if the first dimension - is contiguous. Repacking higher dimensions wouldn't gain us - anything as we still don't know the array stride. */ + is contiguous. Repacking higher dimensions wouldn't gain us + anything as we still don't know the array stride. */ partial = gfc_create_var (boolean_type_node, "partial"); TREE_USED (partial) = 1; tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node); - gfc_add_modify (&block, partial, tmp); + gfc_add_modify (&init, partial, tmp); } else - { - partial = NULL_TREE; - } + partial = NULL_TREE; /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive here, however I think it does the right thing. */ @@ -4504,14 +4497,14 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) { /* Set the first stride. */ stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - stride = gfc_evaluate_now (stride, &block); + stride = gfc_evaluate_now (stride, &init); tmp = fold_build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node); tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp, gfc_index_one_node, stride); stride = GFC_TYPE_ARRAY_STRIDE (type, 0); - gfc_add_modify (&block, stride, tmp); + gfc_add_modify (&init, stride, tmp); /* Allow the user to disable array repacking. */ stmt_unpacked = NULL_TREE; @@ -4546,7 +4539,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) } else tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; - gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp)); + gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp)); offset = gfc_index_zero_node; size = gfc_index_one_node; @@ -4561,34 +4554,34 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); } else - { + { dubound = NULL_TREE; dlbound = NULL_TREE; - } + } lbound = GFC_TYPE_ARRAY_LBOUND (type, n); if (!INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, sym->as->lower[n], - gfc_array_index_type); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_modify (&block, lbound, se.expr); - } + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, sym->as->lower[n], + gfc_array_index_type); + gfc_add_block_to_block (&init, &se.pre); + gfc_add_modify (&init, lbound, se.expr); + } ubound = GFC_TYPE_ARRAY_UBOUND (type, n); /* Set the desired upper bound. */ if (sym->as->upper[n]) { /* We know what we want the upper bound to be. */ - if (!INTEGER_CST_P (ubound)) - { + if (!INTEGER_CST_P (ubound)) + { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, sym->as->upper[n], - gfc_array_index_type); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_modify (&block, ubound, se.expr); - } + gfc_array_index_type); + gfc_add_block_to_block (&init, &se.pre); + gfc_add_modify (&init, ubound, se.expr); + } /* Check the sizes match. */ if (checkparm) @@ -4607,11 +4600,11 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type, gfc_index_one_node, stride2); - tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2); + tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2); asprintf (&msg, "Dimension %d of array '%s' has extent " - "%%ld instead of %%ld", n+1, sym->name); + "%%ld instead of %%ld", n+1, sym->name); - gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg, + gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, fold_convert (long_integer_type_node, temp), fold_convert (long_integer_type_node, stride2)); @@ -4622,10 +4615,10 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) { /* For assumed shape arrays move the upper bound by the same amount as the lower bound. */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound); - gfc_add_modify (&block, ubound, tmp); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound); + gfc_add_modify (&init, ubound, tmp); } /* The offset of this dimension. offset = offset - lbound * stride. */ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride); @@ -4633,41 +4626,39 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) /* The size of this dimension, and the stride of the next. */ if (n + 1 < sym->as->rank) - { - stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); + { + stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); - if (no_repack || partial != NULL_TREE) - { - stmt_unpacked = - gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); - } + if (no_repack || partial != NULL_TREE) + stmt_unpacked = + gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); - /* Figure out the stride if not a known constant. */ - if (!INTEGER_CST_P (stride)) - { - if (no_repack) - stmt_packed = NULL_TREE; - else - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + /* Figure out the stride if not a known constant. */ + if (!INTEGER_CST_P (stride)) + { + if (no_repack) + stmt_packed = NULL_TREE; + else + { + /* Calculate stride = size * (ubound + 1 - lbound). */ + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, gfc_index_one_node, lbound); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, + size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); - stmt_packed = size; - } + stmt_packed = size; + } - /* Assign the stride. */ - if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) + /* Assign the stride. */ + if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial, stmt_unpacked, stmt_packed); - else - tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; - gfc_add_modify (&block, stride, tmp); - } - } + else + tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; + gfc_add_modify (&init, stride, tmp); + } + } else { stride = GFC_TYPE_ARRAY_SIZE (type); @@ -4681,20 +4672,18 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) ubound, tmp); tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, GFC_TYPE_ARRAY_STRIDE (type, n), tmp); - gfc_add_modify (&block, stride, tmp); + gfc_add_modify (&init, stride, tmp); } } } /* Set the offset. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - gfc_trans_vla_type_sizes (sym, &block); + gfc_trans_vla_type_sizes (sym, &init); - stmt = gfc_finish_block (&block); - - gfc_start_block (&block); + stmtInit = gfc_finish_block (&init); /* Only do the entry/initialization code if the arg is present. */ dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); @@ -4704,18 +4693,18 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) if (optional_arg) { tmp = gfc_conv_expr_present (sym); - stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); + stmtInit = build3_v (COND_EXPR, tmp, stmtInit, + build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&block, stmt); - - /* Add the main function body. */ - gfc_add_expr_to_block (&block, body); /* Cleanup code. */ - if (!no_repack) + if (no_repack) + stmtCleanup = NULL_TREE; + else { + stmtblock_t cleanup; gfc_start_block (&cleanup); - + if (sym->attr.intent != INTENT_IN) { /* Copy the data back. */ @@ -4728,26 +4717,26 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) tmp = gfc_call_free (tmpdesc); gfc_add_expr_to_block (&cleanup, tmp); - stmt = gfc_finish_block (&cleanup); + stmtCleanup = gfc_finish_block (&cleanup); /* Only do the cleanup if the array was repacked. */ - tmp = build_fold_indirect_ref_loc (input_location, - dumdesc); + tmp = build_fold_indirect_ref_loc (input_location, dumdesc); tmp = gfc_conv_descriptor_data_get (tmp); tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc); - stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); + stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, + build_empty_stmt (input_location)); if (optional_arg) - { - tmp = gfc_conv_expr_present (sym); - stmt = build3_v (COND_EXPR, tmp, stmt, - build_empty_stmt (input_location)); - } - gfc_add_expr_to_block (&block, stmt); + { + tmp = gfc_conv_expr_present (sym); + stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, + build_empty_stmt (input_location)); + } } + /* We don't need to free any memory allocated by internal_pack as it will be freed at the end of the function by pop_context. */ - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, stmtInit, stmtCleanup); } @@ -6217,13 +6206,14 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) Do likewise, recursively if necessary, with the allocatable components of derived types. */ -tree -gfc_trans_deferred_array (gfc_symbol * sym, tree body) +void +gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) { tree type; tree tmp; tree descriptor; - stmtblock_t fnblock; + stmtblock_t init; + stmtblock_t cleanup; locus loc; int rank; bool sym_has_alloc_comp; @@ -6237,7 +6227,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) "allocatable attribute or derived type without allocatable " "components."); - gfc_init_block (&fnblock); + gfc_init_block (&init); gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL || TREE_CODE (sym->backend_decl) == PARM_DECL); @@ -6245,16 +6235,15 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock); - gfc_trans_vla_type_sizes (sym, &fnblock); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + gfc_trans_vla_type_sizes (sym, &init); } /* Dummy, use associated and result variables don't need anything special. */ if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result) { - gfc_add_expr_to_block (&fnblock, body); - - return gfc_finish_block (&fnblock); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } gfc_get_backend_locus (&loc); @@ -6268,7 +6257,9 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) { /* SAVEd variables are not freed on exit. */ gfc_trans_static_array_pointer (sym); - return body; + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } /* Get the descriptor type. */ @@ -6283,14 +6274,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) || !gfc_has_default_initializer (sym->ts.u.derived)) { rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&fnblock, tmp); + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, + descriptor, rank); + gfc_add_expr_to_block (&init, tmp); } else - { - tmp = gfc_init_default_dt (sym, NULL, false); - gfc_add_expr_to_block (&fnblock, tmp); - } + gfc_init_default_dt (sym, &init, false); } } else if (!GFC_DESCRIPTOR_TYPE_P (type)) @@ -6298,16 +6287,15 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) /* If the backend_decl is not a descriptor, we must have a pointer to one. */ descriptor = build_fold_indirect_ref_loc (input_location, - sym->backend_decl); + sym->backend_decl); type = TREE_TYPE (descriptor); } /* NULLIFY the data pointer. */ if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save) - gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node); - - gfc_add_expr_to_block (&fnblock, body); + gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); + gfc_init_block (&cleanup); gfc_set_backend_locus (&loc); /* Allocatable arrays need to be freed when they go out of scope. @@ -6318,17 +6306,18 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) int rank; rank = sym->as ? sym->as->rank : 0; tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (&cleanup, tmp); } if (sym->attr.allocatable && sym->attr.dimension && !sym->attr.save && !sym->attr.result) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl); - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (&cleanup, tmp); } - return gfc_finish_block (&fnblock); + gfc_add_init_cleanup (block, gfc_finish_block (&init), + gfc_finish_block (&cleanup)); } /************ Expression Walking Functions ******************/ -- cgit v1.2.1 From 540a8975b511546901446f43b79d46e52690b4f3 Mon Sep 17 00:00:00 2001 From: mikael Date: Sat, 17 Jul 2010 09:57:19 +0000 Subject: 2010-07-17 Mikael Morin * trans-array.c (gfc_free_ss): Don't free beyond ss rank. Access subscript through the "dim" field index. (gfc_trans_create_temp_array): Access ss info through the "dim" field index. (gfc_conv_array_index_offset): Ditto. (gfc_conv_loop_setup): Ditto. (gfc_conv_expr_descriptor): Ditto. (gfc_conv_ss_startstride): Ditto. Update call to gfc_conv_section_startstride. (gfc_conv_section_startstride): Set values along the array dimension. Get array dimension directly from the argument. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162276 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-array.c | 248 +++++++++++++++++++++++++--------------------- 1 file changed, 133 insertions(+), 115 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6dfb0699346..d4f1cdf8f67 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -434,10 +434,10 @@ gfc_free_ss (gfc_ss * ss) switch (ss->type) { case GFC_SS_SECTION: - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + for (n = 0; n < ss->data.info.dimen; n++) { - if (ss->data.info.subscript[n]) - gfc_free_ss_chain (ss->data.info.subscript[n]); + if (ss->data.info.subscript[ss->data.info.dim[n]]) + gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]); } break; @@ -762,25 +762,28 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, for (n = 0; n < info->dimen; n++) { + dim = info->dim[n]; + if (size == NULL_TREE) { /* For a callee allocated array express the loop bounds in terms of the descriptor fields. */ - tmp = - fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]), - gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n])); + tmp = fold_build2 ( + MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), + gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); loop->to[n] = tmp; continue; } /* Store the stride and bound components in the descriptor. */ - gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); + gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[dim], size); - gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], + gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[dim], gfc_index_zero_node); - gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]); + gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[dim], + loop->to[n]); tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, loop->to[n], gfc_index_one_node); @@ -2387,7 +2390,8 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, /* Return the offset for an index. Performs bound checking for elemental - dimensions. Single element references are processed separately. */ + dimensions. Single element references are processed separately. + DIM is the array dimension, I is the loop dimension. */ static tree gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, @@ -2448,14 +2452,14 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, /* Scalarized dimension. */ gcc_assert (info && se->loop); - /* Multiply the loop variable by the stride and delta. */ + /* Multiply the loop variable by the stride and delta. */ index = se->loop->loopvar[i]; - if (!integer_onep (info->stride[i])) + if (!integer_onep (info->stride[dim])) index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, - info->stride[i]); - if (!integer_zerop (info->delta[i])) + info->stride[dim]); + if (!integer_zerop (info->delta[dim])) index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, - info->delta[i]); + info->delta[dim]); break; default: @@ -2467,9 +2471,9 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, /* Temporary array or derived type component. */ gcc_assert (se->loop); index = se->loop->loopvar[se->loop->order[i]]; - if (!integer_zerop (info->delta[i])) + if (!integer_zerop (info->delta[dim])) index = fold_build2 (PLUS_EXPR, gfc_array_index_type, - index, info->delta[i]); + index, info->delta[dim]); } /* Multiply by the stride. */ @@ -2967,7 +2971,7 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) /* Calculate the lower bound of an array section. */ static void -gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) +gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) { gfc_expr *start; gfc_expr *end; @@ -2975,19 +2979,17 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) tree desc; gfc_se se; gfc_ss_info *info; - int dim; gcc_assert (ss->type == GFC_SS_SECTION); info = &ss->data.info; - dim = info->dim[n]; if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) { /* We use a zero-based index to access the vector. */ - info->start[n] = gfc_index_zero_node; - info->stride[n] = gfc_index_one_node; - info->end[n] = NULL; + info->start[dim] = gfc_index_zero_node; + info->stride[dim] = gfc_index_one_node; + info->end[dim] = NULL; return; } @@ -3005,14 +3007,14 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, start, gfc_array_index_type); gfc_add_block_to_block (&loop->pre, &se.pre); - info->start[n] = se.expr; + info->start[dim] = se.expr; } else { /* No lower bound specified so use the bound of the array. */ - info->start[n] = gfc_conv_array_lbound (desc, dim); + info->start[dim] = gfc_conv_array_lbound (desc, dim); } - info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre); + info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre); /* Similarly calculate the end. Although this is not used in the scalarizer, it is needed when checking bounds and where the end @@ -3023,24 +3025,24 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, end, gfc_array_index_type); gfc_add_block_to_block (&loop->pre, &se.pre); - info->end[n] = se.expr; + info->end[dim] = se.expr; } else { /* No upper bound specified so use the bound of the array. */ - info->end[n] = gfc_conv_array_ubound (desc, dim); + info->end[dim] = gfc_conv_array_ubound (desc, dim); } - info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre); + info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre); /* Calculate the stride. */ if (stride == NULL) - info->stride[n] = gfc_index_one_node; + info->stride[dim] = gfc_index_one_node; else { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, stride, gfc_array_index_type); gfc_add_block_to_block (&loop->pre, &se.pre); - info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre); + info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre); } } @@ -3105,7 +3107,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter); for (n = 0; n < ss->data.info.dimen; n++) - gfc_conv_section_startstride (loop, ss, n); + gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]); break; case GFC_SS_INTRINSIC: @@ -3180,11 +3182,10 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) check_upper = true; /* Zero stride is not allowed. */ - tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n], + tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[dim], gfc_index_zero_node); asprintf (&msg, "Zero stride is not allowed, for dimension %d " - "of array '%s'", info->dim[n]+1, - ss->expr->symtree->name); + "of array '%s'", dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp, &inner, &ss->expr->where, msg); gfc_free (msg); @@ -3192,27 +3193,27 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) desc = ss->data.info.descriptor; /* This is the run-time equivalent of resolve.c's - check_dimension(). The logical is more readable there - than it is here, with all the trees. */ + check_dimension(). The logical is more readable there + than it is here, with all the trees. */ lbound = gfc_conv_array_lbound (desc, dim); - end = info->end[n]; + end = info->end[dim]; if (check_upper) ubound = gfc_conv_array_ubound (desc, dim); else ubound = NULL; /* non_zerosized is true when the selected range is not - empty. */ + empty. */ stride_pos = fold_build2 (GT_EXPR, boolean_type_node, - info->stride[n], gfc_index_zero_node); - tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n], + info->stride[dim], gfc_index_zero_node); + tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[dim], end); stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, stride_pos, tmp); stride_neg = fold_build2 (LT_EXPR, boolean_type_node, - info->stride[n], gfc_index_zero_node); - tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n], + info->stride[dim], gfc_index_zero_node); + tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[dim], end); stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, stride_neg, tmp); @@ -3225,41 +3226,41 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) error message. */ if (check_upper) { - tmp = fold_build2 (LT_EXPR, boolean_type_node, - info->start[n], lbound); + tmp = fold_build2 (LT_EXPR, boolean_type_node, + info->start[dim], lbound); tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp); tmp2 = fold_build2 (GT_EXPR, boolean_type_node, - info->start[n], ubound); + info->start[dim], ubound); tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp2); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (true, false, tmp, &inner, + "outside of expected range (%%ld:%%ld)", + dim + 1, ss->expr->symtree->name); + gfc_trans_runtime_check (true, false, tmp, &inner, &ss->expr->where, msg, - fold_convert (long_integer_type_node, info->start[n]), - fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound), fold_convert (long_integer_type_node, ubound)); - gfc_trans_runtime_check (true, false, tmp2, &inner, + gfc_trans_runtime_check (true, false, tmp2, &inner, &ss->expr->where, msg, - fold_convert (long_integer_type_node, info->start[n]), - fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound), fold_convert (long_integer_type_node, ubound)); gfc_free (msg); } else { - tmp = fold_build2 (LT_EXPR, boolean_type_node, - info->start[n], lbound); + tmp = fold_build2 (LT_EXPR, boolean_type_node, + info->start[dim], lbound); tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (true, false, tmp, &inner, + "below lower bound of %%ld", + dim + 1, ss->expr->symtree->name); + gfc_trans_runtime_check (true, false, tmp, &inner, &ss->expr->where, msg, - fold_convert (long_integer_type_node, info->start[n]), + fold_convert (long_integer_type_node, info->start[dim]), fold_convert (long_integer_type_node, lbound)); gfc_free (msg); } @@ -3269,9 +3270,9 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) and check it against both lower and upper bounds. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, - info->start[n]); + info->start[dim]); tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp, - info->stride[n]); + info->stride[dim]); tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, tmp); tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound); @@ -3283,8 +3284,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp3); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - info->dim[n]+1, ss->expr->symtree->name); + "outside of expected range (%%ld:%%ld)", + dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp2, &inner, &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp), @@ -3300,32 +3301,32 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) else { asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - info->dim[n]+1, ss->expr->symtree->name); + "below lower bound of %%ld", + dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp2, &inner, &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp), fold_convert (long_integer_type_node, lbound)); gfc_free (msg); } - + /* Check the section sizes match. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, - info->start[n]); + info->start[dim]); tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp, - info->stride[n]); + info->stride[dim]); tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, gfc_index_one_node, tmp); tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp, build_int_cst (gfc_array_index_type, 0)); /* We remember the size of the first section, and check all the - others against this. */ + others against this. */ if (size[n]) { tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]); asprintf (&msg, "Array bound mismatch for dimension %d " "of array '%s' (%%ld/%%ld)", - info->dim[n]+1, ss->expr->symtree->name); + dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp3, &inner, &ss->expr->where, msg, @@ -3517,7 +3518,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, void gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) { - int n; + int n, dim, spec_dim; gfc_ss_info *info; gfc_ss_info *specinfo; gfc_ss *ss; @@ -3533,14 +3534,34 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) loopspec[n] = NULL; dynamic[n] = false; /* We use one SS term, and use that to determine the bounds of the - loop for this dimension. We try to pick the simplest term. */ + loop for this dimension. We try to pick the simplest term. */ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) { + if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE) + continue; + + info = &ss->data.info; + dim = info->dim[n]; + + if (loopspec[n] != NULL) + { + specinfo = &loopspec[n]->data.info; + spec_dim = specinfo->dim[n]; + } + else + { + /* Silence unitialized warnings. */ + specinfo = NULL; + spec_dim = 0; + } + if (ss->shape) { + gcc_assert (ss->shape[dim]); /* The frontend has worked out the size for us. */ - if (!loopspec[n] || !loopspec[n]->shape - || !integer_zerop (loopspec[n]->data.info.start[n])) + if (!loopspec[n] + || !loopspec[n]->shape + || !integer_zerop (specinfo->start[spec_dim])) /* Prefer zero-based descriptors if possible. */ loopspec[n] = ss; continue; @@ -3567,22 +3588,16 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) /* TODO: Pick the best bound if we have a choice between a function and something else. */ - if (ss->type == GFC_SS_FUNCTION) - { - loopspec[n] = ss; - continue; - } + if (ss->type == GFC_SS_FUNCTION) + { + loopspec[n] = ss; + continue; + } if (ss->type != GFC_SS_SECTION) continue; - if (loopspec[n]) - specinfo = &loopspec[n]->data.info; - else - specinfo = NULL; - info = &ss->data.info; - - if (!specinfo) + if (!loopspec[n]) loopspec[n] = ss; /* Criteria for choosing a loop specifier (most important first): doesn't need realloc @@ -3593,14 +3608,14 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) */ else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n]) loopspec[n] = ss; - else if (integer_onep (info->stride[n]) - && !integer_onep (specinfo->stride[n])) + else if (integer_onep (info->stride[dim]) + && !integer_onep (specinfo->stride[spec_dim])) loopspec[n] = ss; - else if (INTEGER_CST_P (info->stride[n]) - && !INTEGER_CST_P (specinfo->stride[n])) + else if (INTEGER_CST_P (info->stride[dim]) + && !INTEGER_CST_P (specinfo->stride[spec_dim])) loopspec[n] = ss; - else if (INTEGER_CST_P (info->start[n]) - && !INTEGER_CST_P (specinfo->start[n])) + else if (INTEGER_CST_P (info->start[dim]) + && !INTEGER_CST_P (specinfo->start[spec_dim])) loopspec[n] = ss; /* We don't work out the upper bound. else if (INTEGER_CST_P (info->finish[n]) @@ -3613,26 +3628,27 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) gcc_assert (loopspec[n]); info = &loopspec[n]->data.info; + dim = info->dim[n]; /* Set the extents of this range. */ cshape = loopspec[n]->shape; - if (cshape && INTEGER_CST_P (info->start[n]) - && INTEGER_CST_P (info->stride[n])) + if (cshape && INTEGER_CST_P (info->start[dim]) + && INTEGER_CST_P (info->stride[dim])) { - loop->from[n] = info->start[n]; + loop->from[n] = info->start[dim]; mpz_set (i, cshape[n]); mpz_sub_ui (i, i, 1); /* To = from + (size - 1) * stride. */ tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); - if (!integer_onep (info->stride[n])) + if (!integer_onep (info->stride[dim])) tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, info->stride[n]); + tmp, info->stride[dim]); loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type, loop->from[n], tmp); } else { - loop->from[n] = info->start[n]; + loop->from[n] = info->start[dim]; switch (loopspec[n]->type) { case GFC_SS_CONSTRUCTOR: @@ -3644,7 +3660,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) case GFC_SS_SECTION: /* Use the end expression if it exists and is not constant, so that it is only evaluated once. */ - loop->to[n] = info->end[n]; + loop->to[n] = info->end[dim]; break; case GFC_SS_FUNCTION: @@ -3658,20 +3674,20 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) } /* Transform everything so we have a simple incrementing variable. */ - if (integer_onep (info->stride[n])) - info->delta[n] = gfc_index_zero_node; + if (integer_onep (info->stride[dim])) + info->delta[dim] = gfc_index_zero_node; else { /* Set the delta for this section. */ - info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre); + info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre); /* Number of iterations is (end - start + step) / step. with start = 0, this simplifies to last = end / step; for (i = 0; i<=last; i++){...}; */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop->to[n], loop->from[n]); - tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, - tmp, info->stride[n]); + tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, + tmp, info->stride[dim]); tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp, build_int_cst (gfc_array_index_type, -1)); loop->to[n] = gfc_evaluate_now (tmp, &loop->pre); @@ -3732,18 +3748,20 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) /* If we are specifying the range the delta is already set. */ if (loopspec[n] != ss) { + dim = ss->data.info.dim[n]; + /* Calculate the offset relative to the loop variable. - First multiply by the stride. */ + First multiply by the stride. */ tmp = loop->from[n]; - if (!integer_onep (info->stride[n])) + if (!integer_onep (info->stride[dim])) tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, info->stride[n]); + tmp, info->stride[dim]); /* Then subtract this from our starting value. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - info->start[n], tmp); + info->start[dim], tmp); - info->delta[n] = gfc_evaluate_now (tmp, &loop->pre); + info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre); } } } @@ -5296,7 +5314,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gcc_assert (info->dim[dim] == n); /* Evaluate and remember the start of the section. */ - start = info->start[dim]; + start = info->start[n]; stride = gfc_evaluate_now (stride, &loop.pre); } @@ -5343,11 +5361,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) /* Multiply the stride by the section stride to get the total stride. */ stride = fold_build2 (MULT_EXPR, gfc_array_index_type, - stride, info->stride[dim]); + stride, info->stride[n]); if (se->direct_byref - && info->ref - && info->ref->u.ar.type != AR_FULL) + && info->ref + && info->ref->u.ar.type != AR_FULL) { base = fold_build2 (MINUS_EXPR, TREE_TYPE (base), base, stride); -- 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-array.c | 30 +++++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index d4f1cdf8f67..cca4ecc4d9c 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2180,9 +2180,12 @@ gfc_init_loopinfo (gfc_loopinfo * loop) gfc_init_block (&loop->pre); gfc_init_block (&loop->post); - /* Initially scalarize in order. */ + /* Initially scalarize in order and default to no loop reversal. */ for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - loop->order[n] = n; + { + loop->order[n] = n; + loop->reverse[n] = GFC_CANNOT_REVERSE; + } loop->ss = gfc_ss_terminator; } @@ -2842,8 +2845,18 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, } else { + bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET) + && (loop->temp_ss == NULL); + loopbody = gfc_finish_block (pbody); + if (reverse_loop) + { + tmp = loop->from[n]; + loop->from[n] = loop->to[n]; + loop->to[n] = tmp; + } + /* Initialize the loopvar. */ if (loop->loopvar[n] != loop->from[n]) gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]); @@ -2854,8 +2867,8 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, gfc_init_block (&block); /* The exit condition. */ - cond = fold_build2 (GT_EXPR, boolean_type_node, - loop->loopvar[n], loop->to[n]); + cond = fold_build2 (reverse_loop ? LT_EXPR : GT_EXPR, + boolean_type_node, loop->loopvar[n], loop->to[n]); tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); @@ -2865,8 +2878,10 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, gfc_add_expr_to_block (&block, loopbody); /* Increment the loopvar. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - loop->loopvar[n], gfc_index_one_node); + tmp = fold_build2 (reverse_loop ? MINUS_EXPR : PLUS_EXPR, + gfc_array_index_type, loop->loopvar[n], + gfc_index_one_node); + gfc_add_modify (&block, loop->loopvar[n], tmp); /* Build the loop. */ @@ -3449,7 +3464,8 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, lref = dest->expr->ref; rref = ss->expr->ref; - nDepend = gfc_dep_resolver (lref, rref); + nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]); + if (nDepend == 1) break; #if 0 -- cgit v1.2.1