From 5d50997a4873b2ff4acdfe03f24b81d7ada048fd Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 24 Jul 2009 11:00:01 +0000 Subject: 2009-07-24 Janus Weil PR fortran/40822 * array.c (gfc_resolve_character_array_constructor): Use new function gfc_new_charlen. * decl.c (add_init_expr_to_sym,variable_decl,match_char_spec, gfc_match_implicit): Ditto. * expr.c (gfc_simplify_expr): Ditto. * gfortran.h (gfc_new_charlen): New prototype. * iresolve.c (check_charlen_present,gfc_resolve_char_achar): Use new function gfc_new_charlen. * module.c (mio_charlen): Ditto. * resolve.c (gfc_resolve_substring_charlen, gfc_resolve_character_operator,fixup_charlen,resolve_fl_derived, resolve_symbol): Ditto. * symbol.c (gfc_new_charlen): New function to create a new gfc_charlen structure and add it to a namespace. (gfc_copy_formal_args_intr): Make sure ts.cl is present for CHARACTER variables. 2009-07-24 Janus Weil PR fortran/40822 * gfortran.dg/char_length_16.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150047 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 4d3345f3fd4..2fee4658a0d 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1599,9 +1599,7 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) goto got_charlen; } - expr->ts.cl = gfc_get_charlen (); - expr->ts.cl->next = gfc_current_ns->cl_list; - gfc_current_ns->cl_list = expr->ts.cl; + expr->ts.cl = gfc_new_charlen (gfc_current_ns); } got_charlen: -- 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/array.c | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 2fee4658a0d..2e12a146ae0 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -968,8 +968,8 @@ done: else expr->ts.type = BT_UNKNOWN; - if (expr->ts.cl) - expr->ts.cl->length_from_typespec = seen_ts; + if (expr->ts.u.cl) + expr->ts.u.cl->length_from_typespec = seen_ts; expr->where = where; expr->rank = 1; @@ -1588,25 +1588,25 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) gcc_assert (expr->expr_type == EXPR_ARRAY); gcc_assert (expr->ts.type == BT_CHARACTER); - if (expr->ts.cl == NULL) + if (expr->ts.u.cl == NULL) { for (p = expr->value.constructor; p; p = p->next) - if (p->expr->ts.cl != NULL) + if (p->expr->ts.u.cl != NULL) { /* Ensure that if there is a char_len around that it is used; otherwise the middle-end confuses them! */ - expr->ts.cl = p->expr->ts.cl; + expr->ts.u.cl = p->expr->ts.u.cl; goto got_charlen; } - expr->ts.cl = gfc_new_charlen (gfc_current_ns); + expr->ts.u.cl = gfc_new_charlen (gfc_current_ns); } got_charlen: found_length = -1; - if (expr->ts.cl->length == NULL) + if (expr->ts.u.cl->length == NULL) { /* Check that all constant string elements have the same length until we reach the end or find a variable-length one. */ @@ -1630,11 +1630,11 @@ got_charlen: - mpz_get_ui (ref->u.ss.start->value.integer) + 1; current_length = (int) j; } - else if (p->expr->ts.cl && p->expr->ts.cl->length - && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT) + else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length + && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) { long j; - j = mpz_get_si (p->expr->ts.cl->length->value.integer); + j = mpz_get_si (p->expr->ts.u.cl->length->value.integer); current_length = (int) j; } else @@ -1658,18 +1658,18 @@ got_charlen: gcc_assert (found_length != -1); /* Update the character length of the array constructor. */ - expr->ts.cl->length = gfc_int_expr (found_length); + expr->ts.u.cl->length = gfc_int_expr (found_length); } else { /* We've got a character length specified. It should be an integer, otherwise an error is signalled elsewhere. */ - gcc_assert (expr->ts.cl->length); + gcc_assert (expr->ts.u.cl->length); /* If we've got a constant character length, pad according to this. gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets max_length only if they pass. */ - gfc_extract_int (expr->ts.cl->length, &found_length); + gfc_extract_int (expr->ts.u.cl->length, &found_length); /* Now pad/truncate the elements accordingly to the specified character length. This is ok inside this conditional, as in the case above @@ -1683,16 +1683,16 @@ got_charlen: int current_length = -1; bool has_ts; - if (p->expr->ts.cl && p->expr->ts.cl->length) + if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) { - cl = p->expr->ts.cl->length; + cl = p->expr->ts.u.cl->length; gfc_extract_int (cl, ¤t_length); } /* If gfc_extract_int above set current_length, we implicitly know the type is BT_INTEGER and it's EXPR_CONSTANT. */ - has_ts = (expr->ts.cl && expr->ts.cl->length_from_typespec); + has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec); if (! cl || (current_length != -1 && current_length < found_length)) -- cgit v1.2.1 From d270ce529b4bdd51b952f8ed87746b9e77ada4c2 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 17 Aug 2009 09:11:00 +0000 Subject: 2009-08-17 Janus Weil PR fortran/40877 * array.c (gfc_resolve_character_array_constructor): Add NULL argument to gfc_new_charlen. * decl.c (add_init_expr_to_sym,variable_decl,match_char_spec, gfc_match_implicit): Ditto. * expr.c (simplify_const_ref): Fix memory leak. (gfc_simplify_expr): Add NULL argument to gfc_new_charlen. * gfortran.h (gfc_new_charlen): Modified prototype. * iresolve.c (check_charlen_present,gfc_resolve_char_achar): Add NULL argument to gfc_new_charlen. * module.c (mio_charlen): Ditto. * resolve.c (gfc_resolve_substring_charlen, gfc_resolve_character_operator,fixup_charlen): Ditto. (resolve_fl_derived,resolve_symbol): Add argument to gfc_charlen. * symbol.c (gfc_new_charlen): Add argument 'old_cl' (to make a copy of an existing charlen). (gfc_set_default_type,generate_isocbinding_symbol): Fix memory leak. (gfc_copy_formal_args_intr): Add NULL argument to gfc_new_charlen. * trans-decl.c (create_function_arglist): Fix memory leak. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150823 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 2e12a146ae0..3ceb0e75181 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1599,7 +1599,7 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) goto got_charlen; } - expr->ts.u.cl = gfc_new_charlen (gfc_current_ns); + expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); } got_charlen: -- cgit v1.2.1 From e8152f13490bf1b3e3a94c318d83a750d562e5b2 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 31 Aug 2009 19:08:03 +0000 Subject: 2009-08-31 Janus Weil Paul Thomas PR fortran/40940 * array.c (gfc_match_array_constructor): Rename gfc_match_type_spec. * decl.c (gfc_match_type_spec): Rename to gfc_match_decl_type_spec, and reject CLASS with -std=f95. (gfc_match_implicit, gfc_match_data_decl,gfc_match_prefix, match_procedure_interface): Rename gfc_match_type_spec. * gfortran.h (gfc_type_compatible): Add prototype. * match.h (gfc_match_type_spec): Rename to gfc_match_decl_type_spec. * match.c (match_intrinsic_typespec): Rename to match_type_spec, and add handling of derived types. (gfc_match_allocate): Rename match_intrinsic_typespec and check type compatibility of derived types. * symbol.c (gfc_type_compatible): New function to check if two types are compatible. 2009-08-31 Janus Weil PR fortran/40940 * gfortran.dg/allocate_derived_1.f90: New. * gfortran.dg/class_3.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151244 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 3ceb0e75181..e1a5f25badf 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -907,7 +907,7 @@ gfc_match_array_constructor (gfc_expr **result) seen_ts = false; /* Try to match an optional "type-spec ::" */ - if (gfc_match_type_spec (&ts, 0) == MATCH_YES) + if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES) { seen_ts = (gfc_match (" ::") == MATCH_YES); -- 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/array.c | 38 +++++++++++++++++++++++++++++++------- 1 file changed, 31 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index e1a5f25badf..7bb51003418 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1237,7 +1237,6 @@ count_elements (gfc_expr *e) static gfc_try extract_element (gfc_expr *e) { - if (e->rank != 0) { /* Something unextractable */ gfc_free_expr (e); @@ -1250,6 +1249,7 @@ extract_element (gfc_expr *e) gfc_free_expr (e); current_expand.extract_count++; + return SUCCESS; } @@ -1495,7 +1495,7 @@ done: FAILURE if not so. */ static gfc_try -constant_element (gfc_expr *e) +is_constant_element (gfc_expr *e) { int rv; @@ -1517,14 +1517,38 @@ gfc_constant_ac (gfc_expr *e) { expand_info expand_save; gfc_try rc; + gfc_constructor * con; + + rc = SUCCESS; - iter_stack = NULL; - expand_save = current_expand; - current_expand.expand_work_function = constant_element; + if (e->value.constructor + && e->value.constructor->expr->expr_type == EXPR_ARRAY + && !e->value.constructor->iterator) + { + /* Expand the constructor. */ + iter_stack = NULL; + expand_save = current_expand; + current_expand.expand_work_function = is_constant_element; - rc = expand_constructor (e->value.constructor); + rc = expand_constructor (e->value.constructor); + + current_expand = expand_save; + } + else + { + /* No need to expand this further. */ + for (con = e->value.constructor; con; con = con->next) + { + if (con->expr->expr_type == EXPR_CONSTANT) + continue; + else + { + if (!gfc_is_constant_expr (con->expr)) + rc = FAILURE; + } + } + } - current_expand = expand_save; if (rc == FAILURE) return 0; -- cgit v1.2.1 From e4c32cf4092885a3a13502b21eb72c9395ea3b85 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 24 Jan 2010 08:10:47 +0000 Subject: 2010-01-24 Tobias Burnus PR fortran/39304 * array.c (gfc_array_dimen_size): Use correct specific function in the check. 2010-01-24 Tobias Burnus PR fortran/39304 * gfortran.dg/generic_20.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156195 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 7bb51003418..139609cca4b 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -2053,7 +2053,15 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) return SUCCESS; } - if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE) + if (array->symtree->n.sym->attr.generic + && !array->symtree->n.sym->attr.intrinsic) + { + if (spec_dimen_size (array->value.function.esym->as, dimen, result) + == FAILURE) + return FAILURE; + } + else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) + == FAILURE) return FAILURE; break; -- cgit v1.2.1 From a93489b1fade2879369bfda69f05f3501a2eaaf6 Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 25 Jan 2010 16:21:42 +0000 Subject: 2010-01-25 Tobias Burnus PR fortran/42858 * array.c (gfc_array_dimen_size): Fix intrinsic procedure check. 2010-01-25 Tobias Burnus PR fortran/42858 * gfortran.dg/generic_21.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156214 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 139609cca4b..094026f0bcc 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1,5 +1,5 @@ /* Array things - Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -2054,7 +2054,7 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) } if (array->symtree->n.sym->attr.generic - && !array->symtree->n.sym->attr.intrinsic) + && array->value.function.esym != NULL) { if (spec_dimen_size (array->value.function.esym->as, dimen, result) == FAILURE) -- cgit v1.2.1 From 9640c8e1ecf6463ed87865cbe14007381ace9862 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Wed, 10 Feb 2010 03:31:02 +0000 Subject: 2010-02-09 Jerry DeLisle PR fortran/42999 * array.c (gfc_constant_ac): Do not prevent expansion of constructors with iterators. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156642 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 094026f0bcc..e0714e3049a 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1522,8 +1522,7 @@ gfc_constant_ac (gfc_expr *e) rc = SUCCESS; if (e->value.constructor - && e->value.constructor->expr->expr_type == EXPR_ARRAY - && !e->value.constructor->iterator) + && e->value.constructor->expr->expr_type == EXPR_ARRAY) { /* Expand the constructor. */ iter_stack = NULL; -- cgit v1.2.1 From aff518b0c6c0be70a7a986a3abe418ddc323eaf8 Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Apr 2010 18:16:13 +0000 Subject: 2010-04-06 Tobias Burnus PR fortran/18918 * array.c (gfc_free_array_spec,gfc_resolve_array_spec, match_array_element_spec,gfc_copy_array_spec, gfc_compare_array_spec): Include corank. (match_array_element_spec,gfc_set_array_spec): Support codimension. * decl.c (build_sym,build_struct,variable_decl, match_attr_spec,attr_decl1,cray_pointer_decl, gfc_match_volatile): Add codimension. (gfc_match_codimension): New function. * dump-parse-tree.c (show_array_spec,show_attr): Support * codimension. * gfortran.h (symbol_attribute,gfc_array_spec): Ditto. (gfc_add_codimension): New function prototype. * match.h (gfc_match_codimension): New function prototype. (gfc_match_array_spec): Update prototype * match.c (gfc_match_common): Update gfc_match_array_spec call. * module.c (MOD_VERSION): Bump. (mio_symbol_attribute): Support coarray attributes. (mio_array_spec): Add corank support. * parse.c (decode_specification_statement,decode_statement, parse_derived): Add coarray support. * resolve.c (resolve_formal_arglist, was_declared, is_non_constant_shape_array, resolve_fl_variable, resolve_fl_derived, resolve_symbol): Add coarray support. * symbol.c (check_conflict, gfc_add_volatile, gfc_copy_attr, gfc_build_class_symbol): Add coarray support. (gfc_add_codimension): New function. 2010-04-06 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_4.f90: New test. * gfortran.dg/coarray_5.f90: New test. * gfortran.dg/coarray_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158012 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 235 +++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 213 insertions(+), 22 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index e0714e3049a..4b2ccf643c5 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -188,7 +188,7 @@ gfc_free_array_spec (gfc_array_spec *as) if (as == NULL) return; - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { gfc_free_expr (as->lower[i]); gfc_free_expr (as->upper[i]); @@ -234,7 +234,7 @@ gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) if (as == NULL) return SUCCESS; - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { e = as->lower[i]; if (resolve_array_bound (e, check_constant) == FAILURE) @@ -290,8 +290,8 @@ match_array_element_spec (gfc_array_spec *as) gfc_expr **upper, **lower; match m; - lower = &as->lower[as->rank - 1]; - upper = &as->upper[as->rank - 1]; + lower = &as->lower[as->rank + as->corank - 1]; + upper = &as->upper[as->rank + as->corank - 1]; if (gfc_match_char ('*') == MATCH_YES) { @@ -335,22 +335,20 @@ match_array_element_spec (gfc_array_spec *as) /* Matches an array specification, incidentally figuring out what sort - it is. */ + it is. Match either a normal array specification, or a coarray spec + or both. Optionally allow [:] for coarrays. */ match -gfc_match_array_spec (gfc_array_spec **asp) +gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) { array_type current_type; + array_type coarray_type = AS_UNKNOWN; gfc_array_spec *as; int i; - - if (gfc_match_char ('(') != MATCH_YES) - { - *asp = NULL; - return MATCH_NO; - } - + as = gfc_get_array_spec (); + as->corank = 0; + as->rank = 0; for (i = 0; i < GFC_MAX_DIMENSIONS; i++) { @@ -358,10 +356,19 @@ gfc_match_array_spec (gfc_array_spec **asp) as->upper[i] = NULL; } - as->rank = 1; + if (!match_dim) + goto coarray; + + if (gfc_match_char ('(') != MATCH_YES) + { + if (!match_codim) + goto done; + goto coarray; + } for (;;) { + as->rank++; current_type = match_array_element_spec (as); if (as->rank == 1) @@ -427,32 +434,150 @@ gfc_match_array_spec (gfc_array_spec **asp) goto cleanup; } - if (as->rank >= GFC_MAX_DIMENSIONS) + if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) { gfc_error ("Array specification at %C has more than %d dimensions", GFC_MAX_DIMENSIONS); goto cleanup; } - if (as->rank >= 7 + if (as->corank + as->rank >= 7 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array " "specification at %C with more than 7 dimensions") == FAILURE) goto cleanup; + } - as->rank++; + if (!match_codim) + goto done; + +coarray: + if (gfc_match_char ('[') != MATCH_YES) + goto done; + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C") + == FAILURE) + goto cleanup; + + for (;;) + { + as->corank++; + current_type = match_array_element_spec (as); + + if (current_type == AS_UNKNOWN) + goto cleanup; + + if (as->rank && as->type != AS_DEFERRED && current_type == AS_DEFERRED) + { + gfc_error ("Array at %C has non-deferred shape and deferred " + "coshape"); + goto cleanup; + } + if (as->rank && as->type == AS_DEFERRED && current_type != AS_DEFERRED) + { + gfc_error ("Array at %C has deferred shape and non-deferred " + "coshape"); + goto cleanup; + } + + if (as->corank == 1) + coarray_type = current_type; + else + switch (coarray_type) + { /* See how current spec meshes with the existing. */ + case AS_UNKNOWN: + goto cleanup; + + case AS_EXPLICIT: + if (current_type == AS_ASSUMED_SIZE) + { + coarray_type = AS_ASSUMED_SIZE; + break; + } + + if (current_type == AS_EXPLICIT) + break; + + gfc_error ("Bad array specification for an explicitly " + "shaped array at %C"); + + goto cleanup; + + case AS_ASSUMED_SHAPE: + if ((current_type == AS_ASSUMED_SHAPE) + || (current_type == AS_DEFERRED)) + break; + + gfc_error ("Bad array specification for assumed shape " + "array at %C"); + goto cleanup; + + case AS_DEFERRED: + if (current_type == AS_DEFERRED) + break; + + if (current_type == AS_ASSUMED_SHAPE) + { + as->type = AS_ASSUMED_SHAPE; + break; + } + + gfc_error ("Bad specification for deferred shape array at %C"); + goto cleanup; + + case AS_ASSUMED_SIZE: + gfc_error ("Bad specification for assumed size array at %C"); + goto cleanup; + } + + if (gfc_match_char (']') == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected another dimension in array declaration at %C"); + goto cleanup; + } + + if (as->corank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("Array specification at %C has more than %d " + "dimensions", GFC_MAX_DIMENSIONS); + goto cleanup; + } + } + + if (current_type == AS_EXPLICIT) + { + gfc_error ("Upper bound of last coarray dimension must be '*' at %C"); + goto cleanup; + } + + if (as->rank == 0 && coarray_type == AS_ASSUMED_SIZE) + as->type = AS_EXPLICIT; + else if (as->rank == 0) + as->type = coarray_type; + +done: + if (as->rank == 0 && as->corank == 0) + { + *asp = NULL; + gfc_free_array_spec (as); + return MATCH_NO; } /* If a lower bounds of an assumed shape array is blank, put in one. */ if (as->type == AS_ASSUMED_SHAPE) { - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { if (as->lower[i] == NULL) as->lower[i] = gfc_int_expr (1); } } + *asp = as; + return MATCH_YES; cleanup: @@ -469,14 +594,77 @@ cleanup: gfc_try gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) { + int i; + if (as == NULL) return SUCCESS; - if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE) + if (as->rank + && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE) return FAILURE; - sym->as = as; + if (as->corank + && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE) + return FAILURE; + + if (sym->as == NULL) + { + sym->as = as; + return SUCCESS; + } + + if (sym->as->type == AS_DEFERRED && as->type != AS_DEFERRED) + { + gfc_error ("'%s' at %L has deferred shape and non-deferred coshape", + sym->name, error_loc); + return FAILURE; + } + + if (sym->as->type != AS_DEFERRED && as->type == AS_DEFERRED) + { + gfc_error ("'%s' at %L has non-deferred shape and deferred coshape", + sym->name, error_loc); + return FAILURE; + } + + if (as->corank) + { + /* The "sym" has no corank (checked via gfc_add_codimension). Thus + the codimension is simply added. */ + gcc_assert (as->rank == 0 && sym->as->corank == 0); + + sym->as->corank = as->corank; + for (i = 0; i < as->corank; i++) + { + sym->as->lower[sym->as->rank + i] = as->lower[i]; + sym->as->upper[sym->as->rank + i] = as->upper[i]; + } + } + else + { + /* The "sym" has no rank (checked via gfc_add_dimension). Thus + the dimension is added - but first the codimensions (if existing + need to be shifted to make space for the dimension. */ + gcc_assert (as->corank == 0 && sym->as->rank == 0); + + sym->as->rank = as->rank; + sym->as->type = as->type; + sym->as->cray_pointee = as->cray_pointee; + sym->as->cp_was_assumed = as->cp_was_assumed; + + for (i = 0; i < sym->as->corank; i++) + { + sym->as->lower[as->rank + i] = sym->as->lower[i]; + sym->as->upper[as->rank + i] = sym->as->upper[i]; + } + for (i = 0; i < as->rank; i++) + { + sym->as->lower[i] = as->lower[i]; + sym->as->upper[i] = as->upper[i]; + } + } + gfc_free (as); return SUCCESS; } @@ -496,7 +684,7 @@ gfc_copy_array_spec (gfc_array_spec *src) *dest = *src; - for (i = 0; i < dest->rank; i++) + for (i = 0; i < dest->rank + dest->corank; i++) { dest->lower[i] = gfc_copy_expr (dest->lower[i]); dest->upper[i] = gfc_copy_expr (dest->upper[i]); @@ -543,6 +731,9 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) if (as1->rank != as2->rank) return 0; + if (as1->corank != as2->corank) + return 0; + if (as1->rank == 0) return 1; @@ -550,7 +741,7 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) return 0; if (as1->type == AS_EXPLICIT) - for (i = 0; i < as1->rank; i++) + for (i = 0; i < as1->rank + as1->corank; i++) { if (compare_bounds (as1->lower[i], as2->lower[i]) == 0) return 0; -- cgit v1.2.1 From 2d640d61aabac1395dd2f903d406cf037df4cf7e Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Apr 2010 18:23:56 +0000 Subject: 2010-04-06 Tobias Burnus PR fortran/18918 * gfortran.h (gfc_array_spec): Add cotype. * array.c (gfc_match_array_spec,gfc_set_array_spec): Use it and defer error diagnostic. * resolve.c (resolve_fl_derived): Add missing check. (resolve_symbol): Add cotype/type check. * parse.c (parse_derived): Fix setting of coarray_comp. 2010-04-06 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_4.f90: Fix test. * gfortran.dg/coarray_6.f90: Add more tests. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158014 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 46 ++++++++++------------------------------------ 1 file changed, 10 insertions(+), 36 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 4b2ccf643c5..c291ad8ca5c 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -342,7 +342,6 @@ match gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) { array_type current_type; - array_type coarray_type = AS_UNKNOWN; gfc_array_spec *as; int i; @@ -467,23 +466,10 @@ coarray: if (current_type == AS_UNKNOWN) goto cleanup; - if (as->rank && as->type != AS_DEFERRED && current_type == AS_DEFERRED) - { - gfc_error ("Array at %C has non-deferred shape and deferred " - "coshape"); - goto cleanup; - } - if (as->rank && as->type == AS_DEFERRED && current_type != AS_DEFERRED) - { - gfc_error ("Array at %C has deferred shape and non-deferred " - "coshape"); - goto cleanup; - } - if (as->corank == 1) - coarray_type = current_type; + as->cotype = current_type; else - switch (coarray_type) + switch (as->cotype) { /* See how current spec meshes with the existing. */ case AS_UNKNOWN: goto cleanup; @@ -491,7 +477,7 @@ coarray: case AS_EXPLICIT: if (current_type == AS_ASSUMED_SIZE) { - coarray_type = AS_ASSUMED_SIZE; + as->cotype = AS_ASSUMED_SIZE; break; } @@ -518,7 +504,7 @@ coarray: if (current_type == AS_ASSUMED_SHAPE) { - as->type = AS_ASSUMED_SHAPE; + as->cotype = AS_ASSUMED_SHAPE; break; } @@ -553,10 +539,11 @@ coarray: goto cleanup; } - if (as->rank == 0 && coarray_type == AS_ASSUMED_SIZE) - as->type = AS_EXPLICIT; - else if (as->rank == 0) - as->type = coarray_type; + if (as->cotype == AS_ASSUMED_SIZE) + as->cotype = AS_EXPLICIT; + + if (as->rank == 0) + as->type = as->cotype; done: if (as->rank == 0 && as->corank == 0) @@ -613,26 +600,13 @@ gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) return SUCCESS; } - if (sym->as->type == AS_DEFERRED && as->type != AS_DEFERRED) - { - gfc_error ("'%s' at %L has deferred shape and non-deferred coshape", - sym->name, error_loc); - return FAILURE; - } - - if (sym->as->type != AS_DEFERRED && as->type == AS_DEFERRED) - { - gfc_error ("'%s' at %L has non-deferred shape and deferred coshape", - sym->name, error_loc); - return FAILURE; - } - if (as->corank) { /* The "sym" has no corank (checked via gfc_add_codimension). Thus the codimension is simply added. */ gcc_assert (as->rank == 0 && sym->as->corank == 0); + sym->as->cotype = as->cotype; sym->as->corank = as->corank; for (i = 0; i < as->corank; i++) { -- cgit v1.2.1 From 76daec3c7eda1449a237a2ff656c08e828d282fa Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Apr 2010 19:03:10 +0000 Subject: 2010-04-06 Tobias Burnus PR fortran/18918 * array.c (gfc_match_array_spec): Add error for -fcoarray=none. * match.c (gfc_match_critical, sync_statement): Ditto. * gfortran.h (gfc_fcoarray): New enum. (gfc_option_t): Use it. * lang.opt (fcoarray): Add new flag. * invoke.texi (fcoarray): Document it. * options.c (gfc_init_options,gfc_handle_option): Handle * -fcoarray=. (gfc_handle_coarray_option): New function. 2010-04-06 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_2.f90: Add dg-options -fcoarray=single. * gfortran.dg/coarray_3.f90: Ditto. * gfortran.dg/coarray_4.f90: Ditto. * gfortran.dg/coarray_5.f90: Ditto. * gfortran.dg/coarray_6.f90: Ditto. * gfortran.dg/coarray_7.f90: Ditto. * gfortran.dg/coarray_8.f90: Ditto. * gfortran.dg/coarray_9.f90: New -fcoarray=none test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158016 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index c291ad8ca5c..4282fd1d8e9 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -458,6 +458,12 @@ coarray: == FAILURE) goto cleanup; + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + goto cleanup; + } + for (;;) { as->corank++; -- 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/array.c | 110 ++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 90 insertions(+), 20 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 4282fd1d8e9..5ceca4bfa85 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -61,12 +61,13 @@ gfc_copy_array_ref (gfc_array_ref *src) expression. */ static match -match_subscript (gfc_array_ref *ar, int init) +match_subscript (gfc_array_ref *ar, int init, bool match_star) { match m; + bool star = false; int i; - i = ar->dimen; + i = ar->dimen + ar->codimen; ar->c_where[i] = gfc_current_locus; ar->start[i] = ar->end[i] = ar->stride[i] = NULL; @@ -81,9 +82,12 @@ match_subscript (gfc_array_ref *ar, int init) goto end_element; /* Get start element. */ - if (init) + if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) + star = true; + + if (!star && init) m = gfc_match_init_expr (&ar->start[i]); - else + else if (!star) m = gfc_match_expr (&ar->start[i]); if (m == MATCH_NO) @@ -92,14 +96,22 @@ match_subscript (gfc_array_ref *ar, int init) return MATCH_ERROR; if (gfc_match_char (':') == MATCH_NO) - return MATCH_YES; + goto matched; + + if (star) + { + gfc_error ("Unexpected '*' in coarray subscript at %C"); + return MATCH_ERROR; + } /* Get an optional end element. Because we've seen the colon, we definitely have a range along this dimension. */ end_element: ar->dimen_type[i] = DIMEN_RANGE; - if (init) + if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) + star = true; + else if (init) m = gfc_match_init_expr (&ar->end[i]); else m = gfc_match_expr (&ar->end[i]); @@ -110,6 +122,12 @@ end_element: /* See if we have an optional stride. */ if (gfc_match_char (':') == MATCH_YES) { + if (star) + { + gfc_error ("Strides not allowed in coarray subscript at %C"); + return MATCH_ERROR; + } + m = init ? gfc_match_init_expr (&ar->stride[i]) : gfc_match_expr (&ar->stride[i]); @@ -119,6 +137,10 @@ end_element: return MATCH_ERROR; } +matched: + if (star) + ar->dimen_type[i] = DIMEN_STAR; + return MATCH_YES; } @@ -128,14 +150,23 @@ end_element: to consist of init expressions. */ match -gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init) +gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, + int corank) { match m; + bool matched_bracket = false; memset (ar, '\0', sizeof (ar)); ar->where = gfc_current_locus; ar->as = as; + ar->type = AR_UNKNOWN; + + if (gfc_match_char ('[') == MATCH_YES) + { + matched_bracket = true; + goto coarray; + } if (gfc_match_char ('(') != MATCH_YES) { @@ -144,34 +175,73 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init) return MATCH_YES; } - ar->type = AR_UNKNOWN; - for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++) { - m = match_subscript (ar, init); + m = match_subscript (ar, init, false); if (m == MATCH_ERROR) - goto error; + return MATCH_ERROR; if (gfc_match_char (')') == MATCH_YES) - goto matched; + { + ar->dimen++; + goto coarray; + } if (gfc_match_char (',') != MATCH_YES) { gfc_error ("Invalid form of array reference at %C"); - goto error; + return MATCH_ERROR; } } gfc_error ("Array reference at %C cannot have more than %d dimensions", GFC_MAX_DIMENSIONS); - -error: return MATCH_ERROR; -matched: - ar->dimen++; +coarray: + if (!matched_bracket && gfc_match_char ('[') != MATCH_YES) + { + if (ar->dimen > 0) + return MATCH_YES; + else + return MATCH_ERROR; + } + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return MATCH_ERROR; + } + + if (corank == 0) + { + gfc_error ("Unexpected coarray designator at %C"); + return MATCH_ERROR; + } + + for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++) + { + m = match_subscript (ar, init, ar->codimen == (corank - 1)); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match_char (']') == MATCH_YES) + { + ar->codimen++; + return MATCH_YES; + } + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Invalid form of coarray reference at %C"); + return MATCH_ERROR; + } + } + + gfc_error ("Array reference at %C cannot have more than %d dimensions", + GFC_MAX_DIMENSIONS); + return MATCH_ERROR; - return MATCH_YES; } @@ -460,8 +530,8 @@ coarray: if (gfc_option.coarray == GFC_FCOARRAY_NONE) { - gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable"); - goto cleanup; + gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + goto cleanup; } for (;;) -- 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/array.c | 448 +++++++++++++--------------------------------------- 1 file changed, 111 insertions(+), 337 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 5ceca4bfa85..c3e366d677b 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -23,6 +23,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "gfortran.h" #include "match.h" +#include "constructor.h" /**************** Array reference matching subroutines *****************/ @@ -365,7 +366,7 @@ match_array_element_spec (gfc_array_spec *as) if (gfc_match_char ('*') == MATCH_YES) { - *lower = gfc_int_expr (1); + *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); return AS_ASSUMED_SIZE; } @@ -382,7 +383,7 @@ match_array_element_spec (gfc_array_spec *as) if (gfc_match_char (':') == MATCH_NO) { - *lower = gfc_int_expr (1); + *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); return AS_EXPLICIT; } @@ -635,7 +636,7 @@ done: for (i = 0; i < as->rank + as->corank; i++) { if (as->lower[i] == NULL) - as->lower[i] = gfc_int_expr (1); + as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); } } @@ -806,151 +807,6 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) /****************** Array constructor functions ******************/ -/* Start an array constructor. The constructor starts with zero - elements and should be appended to by gfc_append_constructor(). */ - -gfc_expr * -gfc_start_constructor (bt type, int kind, locus *where) -{ - gfc_expr *result; - - result = gfc_get_expr (); - - result->expr_type = EXPR_ARRAY; - result->rank = 1; - - result->ts.type = type; - result->ts.kind = kind; - result->where = *where; - return result; -} - - -/* Given an array constructor expression, append the new expression - node onto the constructor. */ - -void -gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr) -{ - gfc_constructor *c; - - if (base->value.constructor == NULL) - base->value.constructor = c = gfc_get_constructor (); - else - { - c = base->value.constructor; - while (c->next) - c = c->next; - - c->next = gfc_get_constructor (); - c = c->next; - } - - c->expr = new_expr; - - if (new_expr - && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind)) - gfc_internal_error ("gfc_append_constructor(): New node has wrong kind"); -} - - -/* Given an array constructor expression, insert the new expression's - constructor onto the base's one according to the offset. */ - -void -gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1) -{ - gfc_constructor *c, *pre; - expr_t type; - int t; - - type = base->expr_type; - - if (base->value.constructor == NULL) - base->value.constructor = c1; - else - { - c = pre = base->value.constructor; - while (c) - { - if (type == EXPR_ARRAY) - { - t = mpz_cmp (c->n.offset, c1->n.offset); - if (t < 0) - { - pre = c; - c = c->next; - } - else if (t == 0) - { - gfc_error ("duplicated initializer"); - break; - } - else - break; - } - else - { - pre = c; - c = c->next; - } - } - - if (pre != c) - { - pre->next = c1; - c1->next = c; - } - else - { - c1->next = c; - base->value.constructor = c1; - } - } -} - - -/* Get a new constructor. */ - -gfc_constructor * -gfc_get_constructor (void) -{ - gfc_constructor *c; - - c = XCNEW (gfc_constructor); - c->expr = NULL; - c->iterator = NULL; - c->next = NULL; - mpz_init_set_si (c->n.offset, 0); - mpz_init_set_si (c->repeat, 0); - return c; -} - - -/* Free chains of gfc_constructor structures. */ - -void -gfc_free_constructor (gfc_constructor *p) -{ - gfc_constructor *next; - - if (p == NULL) - return; - - for (; p; p = next) - { - next = p->next; - - if (p->expr) - gfc_free_expr (p->expr); - if (p->iterator != NULL) - gfc_free_iterator (p->iterator, 1); - mpz_clear (p->n.offset); - mpz_clear (p->repeat); - gfc_free (p); - } -} - /* Given an expression node that might be an array constructor and a symbol, make sure that no iterators in this or child constructors @@ -958,11 +814,12 @@ gfc_free_constructor (gfc_constructor *p) duplicate was found. */ static int -check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master) +check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) { + gfc_constructor *c; gfc_expr *e; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { e = c->expr; @@ -987,14 +844,15 @@ check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master) /* Forward declaration because these functions are mutually recursive. */ -static match match_array_cons_element (gfc_constructor **); +static match match_array_cons_element (gfc_constructor_base *); /* Match a list of array elements. */ static match -match_array_list (gfc_constructor **result) +match_array_list (gfc_constructor_base *result) { - gfc_constructor *p, *head, *tail, *new_cons; + gfc_constructor_base head; + gfc_constructor *p; gfc_iterator iter; locus old_loc; gfc_expr *e; @@ -1013,8 +871,6 @@ match_array_list (gfc_constructor **result) if (m != MATCH_YES) goto cleanup; - tail = head; - if (gfc_match_char (',') != MATCH_YES) { m = MATCH_NO; @@ -1029,7 +885,7 @@ match_array_list (gfc_constructor **result) if (m == MATCH_ERROR) goto cleanup; - m = match_array_cons_element (&new_cons); + m = match_array_cons_element (&head); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) @@ -1040,9 +896,6 @@ match_array_list (gfc_constructor **result) goto cleanup; /* Could be a complex constant */ } - tail->next = new_cons; - tail = new_cons; - if (gfc_match_char (',') != MATCH_YES) { if (n > 2) @@ -1061,19 +914,13 @@ match_array_list (gfc_constructor **result) goto cleanup; } - e = gfc_get_expr (); - e->expr_type = EXPR_ARRAY; - e->where = old_loc; + e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc); e->value.constructor = head; - p = gfc_get_constructor (); - p->where = gfc_current_locus; + p = gfc_constructor_append_expr (result, e, &gfc_current_locus); p->iterator = gfc_get_iterator (); *p->iterator = iter; - p->expr = e; - *result = p; - return MATCH_YES; syntax: @@ -1081,7 +928,7 @@ syntax: m = MATCH_ERROR; cleanup: - gfc_free_constructor (head); + gfc_constructor_free (head); gfc_free_iterator (&iter, 0); gfc_current_locus = old_loc; return m; @@ -1092,9 +939,8 @@ cleanup: single expression or a list of elements. */ static match -match_array_cons_element (gfc_constructor **result) +match_array_cons_element (gfc_constructor_base *result) { - gfc_constructor *p; gfc_expr *expr; match m; @@ -1106,11 +952,7 @@ match_array_cons_element (gfc_constructor **result) if (m != MATCH_YES) return m; - p = gfc_get_constructor (); - p->where = gfc_current_locus; - p->expr = expr; - - *result = p; + gfc_constructor_append_expr (result, expr, &gfc_current_locus); return MATCH_YES; } @@ -1120,7 +962,7 @@ match_array_cons_element (gfc_constructor **result) match gfc_match_array_constructor (gfc_expr **result) { - gfc_constructor *head, *tail, *new_cons; + gfc_constructor_base head, new_cons; gfc_expr *expr; gfc_typespec ts; locus where; @@ -1144,7 +986,7 @@ gfc_match_array_constructor (gfc_expr **result) end_delim = " /)"; where = gfc_current_locus; - head = tail = NULL; + head = new_cons = NULL; seen_ts = false; /* Try to match an optional "type-spec ::" */ @@ -1176,19 +1018,12 @@ gfc_match_array_constructor (gfc_expr **result) for (;;) { - m = match_array_cons_element (&new_cons); + m = match_array_cons_element (&head); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; - if (head == NULL) - head = new_cons; - else - tail->next = new_cons; - - tail = new_cons; - if (gfc_match_char (',') == MATCH_NO) break; } @@ -1197,24 +1032,19 @@ gfc_match_array_constructor (gfc_expr **result) goto syntax; done: - expr = gfc_get_expr (); - - expr->expr_type = EXPR_ARRAY; - - expr->value.constructor = head; /* Size must be calculated at resolution time. */ - if (seen_ts) - expr->ts = ts; + { + expr = gfc_get_array_expr (ts.type, ts.kind, &where); + expr->ts = ts; + } else - expr->ts.type = BT_UNKNOWN; - + expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where); + + expr->value.constructor = head; if (expr->ts.u.cl) expr->ts.u.cl->length_from_typespec = seen_ts; - expr->where = where; - expr->rank = 1; - *result = expr; return MATCH_YES; @@ -1222,7 +1052,7 @@ syntax: gfc_error ("Syntax error in array constructor at %C"); cleanup: - gfc_free_constructor (head); + gfc_constructor_free (head); return MATCH_ERROR; } @@ -1278,11 +1108,12 @@ check_element_type (gfc_expr *expr, bool convert) /* Recursive work function for gfc_check_constructor_type(). */ static gfc_try -check_constructor_type (gfc_constructor *c, bool convert) +check_constructor_type (gfc_constructor_base base, bool convert) { + gfc_constructor *c; gfc_expr *e; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { e = c->expr; @@ -1341,7 +1172,7 @@ cons_stack; static cons_stack *base; -static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *)); +static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *)); /* Check an EXPR_VARIABLE expression in a constructor to make sure that that variable is an iteration variables. */ @@ -1367,13 +1198,14 @@ gfc_check_iter_variable (gfc_expr *expr) constructor, giving variables with the names of iterators a pass. */ static gfc_try -check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *)) +check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *)) { cons_stack element; gfc_expr *e; gfc_try t; + gfc_constructor *c; - for (; c; c = c->next) + for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c)) { e = c->expr; @@ -1427,7 +1259,7 @@ iterator_stack *iter_stack; typedef struct { - gfc_constructor *new_head, *new_tail; + gfc_constructor_base base; int extract_count, extract_n; gfc_expr *extracted; mpz_t *count; @@ -1442,7 +1274,7 @@ expand_info; static expand_info current_expand; -static gfc_try expand_constructor (gfc_constructor *); +static gfc_try expand_constructor (gfc_constructor_base); /* Work function that counts the number of elements present in a @@ -1501,21 +1333,10 @@ extract_element (gfc_expr *e) static gfc_try expand (gfc_expr *e) { - if (current_expand.new_head == NULL) - current_expand.new_head = current_expand.new_tail = - gfc_get_constructor (); - else - { - current_expand.new_tail->next = gfc_get_constructor (); - current_expand.new_tail = current_expand.new_tail->next; - } + gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base, + e, &e->where); - current_expand.new_tail->where = e->where; - current_expand.new_tail->expr = e; - - mpz_set (current_expand.new_tail->n.offset, *current_expand.offset); - current_expand.new_tail->n.component = current_expand.component; - mpz_set (current_expand.new_tail->repeat, *current_expand.repeat); + c->n.component = current_expand.component; return SUCCESS; } @@ -1535,7 +1356,7 @@ gfc_simplify_iterator_var (gfc_expr *e) if (p == NULL) return; /* Variable not found */ - gfc_replace_expr (e, gfc_int_expr (0)); + gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); mpz_set (e->value.integer, p->value); @@ -1649,11 +1470,12 @@ cleanup: passed expression. */ static gfc_try -expand_constructor (gfc_constructor *c) +expand_constructor (gfc_constructor_base base) { + gfc_constructor *c; gfc_expr *e; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c)) { if (c->iterator != NULL) { @@ -1678,9 +1500,9 @@ expand_constructor (gfc_constructor *c) gfc_free_expr (e); return FAILURE; } - current_expand.offset = &c->n.offset; - current_expand.component = c->n.component; + current_expand.offset = &c->offset; current_expand.repeat = &c->repeat; + current_expand.component = c->n.component; if (current_expand.expand_work_function (e) == FAILURE) return FAILURE; } @@ -1688,6 +1510,39 @@ expand_constructor (gfc_constructor *c) } +/* Given an array expression and an element number (starting at zero), + return a pointer to the array element. NULL is returned if the + size of the array has been exceeded. The expression node returned + remains a part of the array and should not be freed. Access is not + efficient at all, but this is another place where things do not + have to be particularly fast. */ + +static gfc_expr * +gfc_get_array_element (gfc_expr *array, int element) +{ + expand_info expand_save; + gfc_expr *e; + gfc_try rc; + + expand_save = current_expand; + current_expand.extract_n = element; + current_expand.expand_work_function = extract_element; + current_expand.extracted = NULL; + current_expand.extract_count = 0; + + iter_stack = NULL; + + rc = expand_constructor (array->value.constructor); + e = current_expand.extracted; + current_expand = expand_save; + + if (rc == FAILURE) + return NULL; + + return e; +} + + /* Top level subroutine for expanding constructors. We only expand constructor if they are small enough. */ @@ -1698,6 +1553,8 @@ gfc_expand_constructor (gfc_expr *e) gfc_expr *f; gfc_try rc; + /* If we can successfully get an array element at the max array size then + the array is too big to expand, so we just return. */ f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor); if (f != NULL) { @@ -1705,8 +1562,9 @@ gfc_expand_constructor (gfc_expr *e) return SUCCESS; } + /* We now know the array is not too big so go ahead and try to expand it. */ expand_save = current_expand; - current_expand.new_head = current_expand.new_tail = NULL; + current_expand.base = NULL; iter_stack = NULL; @@ -1714,13 +1572,13 @@ gfc_expand_constructor (gfc_expr *e) if (expand_constructor (e->value.constructor) == FAILURE) { - gfc_free_constructor (current_expand.new_head); + gfc_constructor_free (current_expand.base); rc = FAILURE; goto done; } - gfc_free_constructor (e->value.constructor); - e->value.constructor = current_expand.new_head; + gfc_constructor_free (e->value.constructor); + e->value.constructor = current_expand.base; rc = SUCCESS; @@ -1758,37 +1616,14 @@ gfc_constant_ac (gfc_expr *e) { expand_info expand_save; gfc_try rc; - gfc_constructor * con; - - rc = SUCCESS; - if (e->value.constructor - && e->value.constructor->expr->expr_type == EXPR_ARRAY) - { - /* Expand the constructor. */ - iter_stack = NULL; - expand_save = current_expand; - current_expand.expand_work_function = is_constant_element; + iter_stack = NULL; + expand_save = current_expand; + current_expand.expand_work_function = is_constant_element; - rc = expand_constructor (e->value.constructor); - - current_expand = expand_save; - } - else - { - /* No need to expand this further. */ - for (con = e->value.constructor; con; con = con->next) - { - if (con->expr->expr_type == EXPR_CONSTANT) - continue; - else - { - if (!gfc_is_constant_expr (con->expr)) - rc = FAILURE; - } - } - } + rc = expand_constructor (e->value.constructor); + current_expand = expand_save; if (rc == FAILURE) return 0; @@ -1802,11 +1637,12 @@ gfc_constant_ac (gfc_expr *e) int gfc_expanded_ac (gfc_expr *e) { - gfc_constructor *p; + gfc_constructor *c; if (e->expr_type == EXPR_ARRAY) - for (p = e->value.constructor; p; p = p->next) - if (p->iterator != NULL || !gfc_expanded_ac (p->expr)) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + if (c->iterator != NULL || !gfc_expanded_ac (c->expr)) return 0; return 1; @@ -1819,19 +1655,20 @@ gfc_expanded_ac (gfc_expr *e) be of the same type. */ static gfc_try -resolve_array_list (gfc_constructor *p) +resolve_array_list (gfc_constructor_base base) { gfc_try t; + gfc_constructor *c; t = SUCCESS; - for (; p; p = p->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { - if (p->iterator != NULL - && gfc_resolve_iterator (p->iterator, false) == FAILURE) + if (c->iterator != NULL + && gfc_resolve_iterator (c->iterator, false) == FAILURE) t = FAILURE; - if (gfc_resolve_expr (p->expr) == FAILURE) + if (gfc_resolve_expr (c->expr) == FAILURE) t = FAILURE; } @@ -1854,7 +1691,8 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) if (expr->ts.u.cl == NULL) { - for (p = expr->value.constructor; p; p = p->next) + for (p = gfc_constructor_first (expr->value.constructor); + p; p = gfc_constructor_next (p)) if (p->expr->ts.u.cl != NULL) { /* Ensure that if there is a char_len around that it is @@ -1875,7 +1713,8 @@ got_charlen: /* Check that all constant string elements have the same length until we reach the end or find a variable-length one. */ - for (p = expr->value.constructor; p; p = p->next) + for (p = gfc_constructor_first (expr->value.constructor); + p; p = gfc_constructor_next (p)) { int current_length = -1; gfc_ref *ref; @@ -1922,7 +1761,8 @@ got_charlen: gcc_assert (found_length != -1); /* Update the character length of the array constructor. */ - expr->ts.u.cl->length = gfc_int_expr (found_length); + expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, found_length); } else { @@ -1940,7 +1780,8 @@ got_charlen: (without typespec) all elements are verified to have the same length anyway. */ if (found_length != -1) - for (p = expr->value.constructor; p; p = p->next) + for (p = gfc_constructor_first (expr->value.constructor); + p; p = gfc_constructor_next (p)) if (p->expr->expr_type == EXPR_CONSTANT) { gfc_expr *cl = NULL; @@ -1990,8 +1831,8 @@ gfc_resolve_array_constructor (gfc_expr *expr) /* Copy an iterator structure. */ -static gfc_iterator * -copy_iterator (gfc_iterator *src) +gfc_iterator * +gfc_copy_iterator (gfc_iterator *src) { gfc_iterator *dest; @@ -2009,73 +1850,6 @@ copy_iterator (gfc_iterator *src) } -/* Copy a constructor structure. */ - -gfc_constructor * -gfc_copy_constructor (gfc_constructor *src) -{ - gfc_constructor *dest; - gfc_constructor *tail; - - if (src == NULL) - return NULL; - - dest = tail = NULL; - while (src) - { - if (dest == NULL) - dest = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } - tail->where = src->where; - tail->expr = gfc_copy_expr (src->expr); - tail->iterator = copy_iterator (src->iterator); - mpz_set (tail->n.offset, src->n.offset); - tail->n.component = src->n.component; - mpz_set (tail->repeat, src->repeat); - src = src->next; - } - - return dest; -} - - -/* Given an array expression and an element number (starting at zero), - return a pointer to the array element. NULL is returned if the - size of the array has been exceeded. The expression node returned - remains a part of the array and should not be freed. Access is not - efficient at all, but this is another place where things do not - have to be particularly fast. */ - -gfc_expr * -gfc_get_array_element (gfc_expr *array, int element) -{ - expand_info expand_save; - gfc_expr *e; - gfc_try rc; - - expand_save = current_expand; - current_expand.extract_n = element; - current_expand.expand_work_function = extract_element; - current_expand.extracted = NULL; - current_expand.extract_count = 0; - - iter_stack = NULL; - - rc = expand_constructor (array->value.constructor); - e = current_expand.extracted; - current_expand = expand_save; - - if (rc == FAILURE) - return NULL; - - return e; -} - - /********* Subroutines for determining the size of an array *********/ /* These are needed just to accommodate RESHAPE(). There are no -- cgit v1.2.1 From a250d5604c330534faa5c2c410c33db5d8253768 Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 14 Apr 2010 05:43:30 +0000 Subject: 2010-04-14 Tobias Burnus PR fortran/18918 * array.c (gfc_find_array_ref): Handle codimensions. (gfc_match_array_spec,gfc_match_array_ref): Use gfc_fatal_error. * check.c (is_coarray, dim_corank_check, gfc_check_lcobound, gfc_check_image_index, gfc_check_this_image, gfc_check_ucobound): New functions. * gfortran.h (gfc_isym_id): Add GFC_ISYM_IMAGE_INDEX, GFC_ISYM_LCOBOUND, GFC_ISYM_THIS_IMAGE, GFC_ISYM_UCOBOUND. * intrinsic.h (add_functions): Add this_image, image_index, lcobound and ucobound intrinsics. * intrinsic.c (gfc_check_lcobound,gfc_check_ucobound, gfc_check_image_index, gfc_check_this_image, gfc_simplify_image_index, gfc_simplify_lcobound, gfc_simplify_this_image, gfc_simplify_ucobound): New function prototypes. * intrinsic.texi (IMAGE_INDEX, LCOBOUND, THIS_IMAGE IMAGE_INDEX): Document new intrinsic functions. * match.c (gfc_match_critical, sync_statement): Make * -fcoarray=none error fatal. * simplify.c (simplify_bound_dim): Handle coarrays. (simplify_bound): Update simplify_bound_dim call. (gfc_simplify_num_images): Add -fcoarray=none check. (simplify_cobound, gfc_simplify_lcobound, gfc_simplify_ucobound, gfc_simplify_ucobound, gfc_simplify_ucobound): New functions. 2010-04-14 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_9.f90: Update dg-errors. * gfortran.dg/coarray_10.f90: New test. * gfortran.dg/coarray_11.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158292 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index c3e366d677b..5487be7aa4f 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -210,7 +210,7 @@ coarray: if (gfc_option.coarray == GFC_FCOARRAY_NONE) { - gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); return MATCH_ERROR; } @@ -531,7 +531,7 @@ coarray: if (gfc_option.coarray == GFC_FCOARRAY_NONE) { - gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); goto cleanup; } @@ -2223,7 +2223,8 @@ gfc_find_array_ref (gfc_expr *e) for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY - && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION)) + && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION + || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0))) break; if (ref == NULL) -- 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/array.c | 2 -- 1 file changed, 2 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 5487be7aa4f..3ffc39714da 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1266,7 +1266,6 @@ typedef struct mpz_t *offset; gfc_component *component; - mpz_t *repeat; gfc_try (*expand_work_function) (gfc_expr *); } @@ -1501,7 +1500,6 @@ expand_constructor (gfc_constructor_base base) return FAILURE; } current_expand.offset = &c->offset; - current_expand.repeat = &c->repeat; current_expand.component = c->n.component; if (current_expand.expand_work_function (e) == FAILURE) return FAILURE; -- cgit v1.2.1 From 148aaa7fa6884e257d205df009ea315b6b521c9c Mon Sep 17 00:00:00 2001 From: dfranke Date: Thu, 13 May 2010 14:08:05 +0000 Subject: gcc/fortran/: 2010-05-13 Daniel Franke PR fortran/35779 * intrinsic.c (gfc_init_expr): Renamed to gfc_init_expr_flag. Updated all usages. * expr.c (init_flag): Removed; use gfc_init_expr_flag everywhere. * array.c (match_array_list): Pass on gfc_init_expr_flag when matching iterators. gcc/testsuite/: 2010-05-13 Daniel Franke PR fortran/35779 * gfortran.dg/initialization_25.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159366 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 3ffc39714da..25c6e140306 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -879,7 +879,7 @@ match_array_list (gfc_constructor_base *result) for (n = 1;; n++) { - m = gfc_match_iterator (&iter, 0); + m = gfc_match_iterator (&iter, gfc_init_expr_flag); if (m == MATCH_YES) break; if (m == MATCH_ERROR) -- cgit v1.2.1 From 95773d67b14432080d189b6c182f1625ac4d2cf6 Mon Sep 17 00:00:00 2001 From: dfranke Date: Sun, 16 May 2010 20:01:06 +0000 Subject: gcc/fortran/: 2010-05-16 Daniel Franke PR fortran/35779 * array.c (match_array_list): Revert functional change of 2010-05-13. gcc/fortran/: 2010-05-16 Daniel Franke PR fortran/35779 * gfortran.dg/initialization_25.f90: Commented testcase. * gfortran.dg/initialization_26.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159465 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 25c6e140306..3ffc39714da 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -879,7 +879,7 @@ match_array_list (gfc_constructor_base *result) for (n = 1;; n++) { - m = gfc_match_iterator (&iter, gfc_init_expr_flag); + m = gfc_match_iterator (&iter, 0); if (m == MATCH_YES) break; if (m == MATCH_ERROR) -- cgit v1.2.1 From 7c9ed47a4f9f6bbc6115e68057ab442ac996395c Mon Sep 17 00:00:00 2001 From: ktietz Date: Thu, 10 Jun 2010 08:06:08 +0000 Subject: 2010-06-10 Kai Tietz * error.c (error_print): Pre-initialize loc by NULL. * openmp.c (resolve_omp_clauses): Add explicit braces to avoid ambigous else. * array.c (match_subscript): Pre-initialize m to MATCH_ERROR. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160525 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 3ffc39714da..64816f28abb 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -64,7 +64,7 @@ gfc_copy_array_ref (gfc_array_ref *src) static match match_subscript (gfc_array_ref *ar, int init, bool match_star) { - match m; + match m = MATCH_ERROR; bool star = false; int i; -- cgit v1.2.1 From 58b069a099182c5367587d098eda613ee3947fec Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Jul 2010 20:56:07 +0000 Subject: 2010-07-06 Tobias Burnus PR fortran/44742 * array.c (gfc_expand_constructor): Add optional diagnostic. * gfortran.h (gfc_expand_constructor): Update prototype. * expr.c (gfc_simplify_expr, check_init_expr, gfc_reduce_init_expr): Update gfc_expand_constructor call. * resolve.c (gfc_resolve_expr): Ditto. 2010-07-06 Tobias Burnus PR fortran/44742 * gfortran.dg/parameter_array_init_6.f90: New. * gfortran.dg/initialization_20.f90: Update dg-error. * gfortran.dg/initialization_24.f90: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161888 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 64816f28abb..0c36f544e6d 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1545,7 +1545,7 @@ gfc_get_array_element (gfc_expr *array, int element) constructor if they are small enough. */ gfc_try -gfc_expand_constructor (gfc_expr *e) +gfc_expand_constructor (gfc_expr *e, bool fatal) { expand_info expand_save; gfc_expr *f; @@ -1557,6 +1557,15 @@ gfc_expand_constructor (gfc_expr *e) if (f != NULL) { gfc_free_expr (f); + if (fatal) + { + gfc_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", &e->where, + gfc_option.flag_max_array_constructor); + return FAILURE; + } return SUCCESS; } -- cgit v1.2.1 From 1da1826b7789821567dedb4a5418c6d61c915d1c Mon Sep 17 00:00:00 2001 From: burnus Date: Thu, 8 Jul 2010 15:17:25 +0000 Subject: 2010-07-08 Tobias Burnus PR fortran/18918 * array.c (gfc_match_array_ref): Better error message for coarrays with too few ranks. (match_subscript): Move one diagnostic to caller. * gfortran.h (gfc_get_corank): Add prottype. * expr.c (gfc_get_corank): New function. * iresolve.c (resolve_bound): Fix rank for cobounds. (gfc_resolve_lbound,gfc_resolve_lcobound, gfc_resolve_ubound, gfc_resolve_ucobound, gfc_resolve_this_image): Update resolve_bound call. 2010-07-08 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_10.f90: Add an additional test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161960 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/array.c | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/array.c') diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 0c36f544e6d..68b6456cdbc 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -91,7 +91,9 @@ match_subscript (gfc_array_ref *ar, int init, bool match_star) else if (!star) m = gfc_match_expr (&ar->start[i]); - if (m == MATCH_NO) + if (m == MATCH_NO && gfc_match_char ('*') == MATCH_YES) + return MATCH_NO; + else if (m == MATCH_NO) gfc_error ("Expected array subscript at %C"); if (m != MATCH_YES) return MATCH_ERROR; @@ -229,12 +231,28 @@ coarray: if (gfc_match_char (']') == MATCH_YES) { ar->codimen++; + if (ar->codimen < corank) + { + gfc_error ("Too few codimensions at %C, expected %d not %d", + corank, ar->codimen); + return MATCH_ERROR; + } return MATCH_YES; } if (gfc_match_char (',') != MATCH_YES) { - gfc_error ("Invalid form of coarray reference at %C"); + if (gfc_match_char ('*') == MATCH_YES) + gfc_error ("Unexpected '*' for codimension %d of %d at %C", + ar->codimen + 1, corank); + else + gfc_error ("Invalid form of coarray reference at %C"); + return MATCH_ERROR; + } + if (ar->codimen >= corank) + { + gfc_error ("Invalid codimension %d at %C, only %d codimensions exist", + ar->codimen + 1, corank); return MATCH_ERROR; } } -- cgit v1.2.1